[FTypeChecker] More informative error message (and more robust code) when typechecking variants.
This commit is contained in:
parent
b1057c92fd
commit
227a4bbaf8
|
@ -46,6 +46,8 @@ module Env = struct
|
||||||
}
|
}
|
||||||
|
|
||||||
exception UnexpectedRecord
|
exception UnexpectedRecord
|
||||||
|
exception DeclarationNotFound of tyconstr_id
|
||||||
|
exception LabelNotFound of label_id
|
||||||
|
|
||||||
let empty = {
|
let empty = {
|
||||||
datatypes = TyConstrMap.empty;
|
datatypes = TyConstrMap.empty;
|
||||||
|
@ -64,19 +66,17 @@ module Env = struct
|
||||||
labels = add_labels e.labels tdescr.labels_descr;
|
labels = add_labels e.labels tdescr.labels_descr;
|
||||||
}
|
}
|
||||||
|
|
||||||
let find_label { labels ; _ } (Label l) =
|
let find_label { labels ; _ } label =
|
||||||
LabelMap.find (Label l) labels
|
try
|
||||||
|
LabelMap.find label labels
|
||||||
|
with Not_found ->
|
||||||
|
raise (LabelNotFound label)
|
||||||
|
|
||||||
let find_decl { datatypes ; _ } (Type tid) =
|
let find_decl { datatypes ; _ } tid =
|
||||||
TyConstrMap.find (Type tid) datatypes
|
try
|
||||||
|
TyConstrMap.find tid datatypes
|
||||||
let label_index { labels_descr ; _ } l =
|
with Not_found ->
|
||||||
let combine i ldescr = (i, ldescr.label_name) in
|
raise (DeclarationNotFound tid)
|
||||||
List.mapi combine labels_descr
|
|
||||||
|> List.find (fun (_, l') -> l = l')
|
|
||||||
|> fst
|
|
||||||
|
|
||||||
let () = ignore label_index
|
|
||||||
|
|
||||||
let map (type b1 b2 t1 t2)
|
let map (type b1 b2 t1 t2)
|
||||||
(f : (b1, t1) decl -> (b2, t2) decl)
|
(f : (b1, t1) decl -> (b2, t2) decl)
|
||||||
|
|
|
@ -34,6 +34,8 @@ module Env : sig
|
||||||
type ('b, 't) t
|
type ('b, 't) t
|
||||||
|
|
||||||
exception UnexpectedRecord
|
exception UnexpectedRecord
|
||||||
|
exception DeclarationNotFound of tyconstr_id
|
||||||
|
exception LabelNotFound of label_id
|
||||||
|
|
||||||
val empty: ('b, 't) t
|
val empty: ('b, 't) t
|
||||||
val add_decl: ('b, 't) t -> ('b, 't) decl -> ('b, 't) t
|
val add_decl: ('b, 't) t -> ('b, 't) decl -> ('b, 't) t
|
||||||
|
|
|
@ -216,5 +216,14 @@ let print_type_error e =
|
||||||
str "Scope error." ++
|
str "Scope error." ++
|
||||||
str "The variable %s is bound twice in a pattern." x
|
str "The variable %s is bound twice in a pattern." x
|
||||||
| ContextNotAbsurd ->
|
| ContextNotAbsurd ->
|
||||||
str "Type error." ++
|
str "Type error." ++
|
||||||
str "The type equations in the typing environment are not contradictory."
|
str "The type equations in the typing environment are not contradictory."
|
||||||
|
| UnexpectedRecord ->
|
||||||
|
str "Type error." ++
|
||||||
|
str "A record was expected."
|
||||||
|
| DeclarationNotFound (Datatype.Type tid) ->
|
||||||
|
str "Scope error." ++
|
||||||
|
str "Unknown type declaration : %s." tid
|
||||||
|
| LabelNotFound (Datatype.Label lid) ->
|
||||||
|
str "Scope error." ++
|
||||||
|
str "Unknown variant constructor : %s." lid
|
||||||
|
|
|
@ -11,6 +11,10 @@ type type_error =
|
||||||
| UnboundTypeVariable of tyvar
|
| UnboundTypeVariable of tyvar
|
||||||
| TwoOccurencesOfSameVariable of string
|
| TwoOccurencesOfSameVariable of string
|
||||||
| ContextNotAbsurd
|
| ContextNotAbsurd
|
||||||
|
| UnexpectedRecord
|
||||||
|
| DeclarationNotFound of Datatype.tyconstr_id
|
||||||
|
| LabelNotFound of Datatype.label_id
|
||||||
|
|
||||||
|
|
||||||
and arity_requirement = Index of int | Total of int
|
and arity_requirement = Index of int | Total of int
|
||||||
|
|
||||||
|
@ -439,9 +443,17 @@ let rec typeof datatype_env env (t : debruijn_term) : debruijn_type =
|
||||||
|
|
||||||
and typeof_variant datatype_env lbl (tid, tyargs) =
|
and typeof_variant datatype_env lbl (tid, tyargs) =
|
||||||
let Datatype.{ data_kind ; type_params ; labels_descr; _ } =
|
let Datatype.{ data_kind ; type_params ; labels_descr; _ } =
|
||||||
Datatype.Env.find_decl datatype_env tid in
|
try
|
||||||
|
Datatype.Env.find_decl datatype_env tid
|
||||||
|
with Datatype.Env.DeclarationNotFound _ ->
|
||||||
|
raise (TypeError (DeclarationNotFound tid))
|
||||||
|
in
|
||||||
let Datatype.{ arg_type; _ } =
|
let Datatype.{ arg_type; _ } =
|
||||||
List.find (fun l -> l.Datatype.label_name = lbl) labels_descr in
|
try
|
||||||
|
List.find (fun l -> l.Datatype.label_name = lbl) labels_descr
|
||||||
|
with Datatype.Env.LabelNotFound _ ->
|
||||||
|
raise (TypeError (LabelNotFound lbl))
|
||||||
|
in
|
||||||
begin
|
begin
|
||||||
match data_kind with
|
match data_kind with
|
||||||
| Datatype.Variant ->
|
| Datatype.Variant ->
|
||||||
|
@ -483,6 +495,7 @@ let typeof datatype_env t =
|
||||||
|
|
||||||
let typeof_result datatype_env u =
|
let typeof_result datatype_env u =
|
||||||
match typeof datatype_env u with
|
match typeof datatype_env u with
|
||||||
| v -> Ok v
|
| v ->
|
||||||
|
Ok v
|
||||||
| exception TypeError e ->
|
| exception TypeError e ->
|
||||||
Error e
|
Error e
|
||||||
|
|
|
@ -13,6 +13,9 @@ type type_error =
|
||||||
| UnboundTypeVariable of tyvar
|
| UnboundTypeVariable of tyvar
|
||||||
| TwoOccurencesOfSameVariable of string
|
| TwoOccurencesOfSameVariable of string
|
||||||
| ContextNotAbsurd
|
| ContextNotAbsurd
|
||||||
|
| UnexpectedRecord
|
||||||
|
| DeclarationNotFound of Datatype.tyconstr_id
|
||||||
|
| LabelNotFound of Datatype.label_id
|
||||||
|
|
||||||
(* An arity-related requirement on a certain (sum or product) type
|
(* An arity-related requirement on a certain (sum or product) type
|
||||||
arising during type-checking:
|
arising during type-checking:
|
||||||
|
|
|
@ -124,6 +124,14 @@ let option_env =
|
||||||
in
|
in
|
||||||
Datatype.Env.add_decl Datatype.Env.empty option_typedecl
|
Datatype.Env.add_decl Datatype.Env.empty option_typedecl
|
||||||
|
|
||||||
|
(* We test this example in an empty datatype environment. It should raise
|
||||||
|
an error indicating that it did not find the label. *)
|
||||||
|
let not_in_env =
|
||||||
|
let alpha = 0 in
|
||||||
|
let label = Datatype.Label "None" in
|
||||||
|
let datatype = Datatype.Type "option", [F.TyForall (alpha, F.TyVar alpha)] in
|
||||||
|
variant label datatype unit
|
||||||
|
|
||||||
(* None *)
|
(* None *)
|
||||||
let none =
|
let none =
|
||||||
let alpha = 0 in
|
let alpha = 0 in
|
||||||
|
@ -675,6 +683,7 @@ let test_suite =
|
||||||
test_ok_from_ast "match with prod" Datatype.Env.empty match_with_prod;
|
test_ok_from_ast "match with prod" Datatype.Env.empty match_with_prod;
|
||||||
test_type_error "match variable bound twice" Datatype.Env.empty
|
test_type_error "match variable bound twice" Datatype.Env.empty
|
||||||
match_variable_bound_twice;
|
match_variable_bound_twice;
|
||||||
|
test_type_error "not in env" Datatype.Env.empty not_in_env;
|
||||||
test_ok_from_ast "unit" option_env unit;
|
test_ok_from_ast "unit" option_env unit;
|
||||||
test_ok_from_ast "none" option_env none;
|
test_ok_from_ast "none" option_env none;
|
||||||
test_ok_from_ast "some" option_env some;
|
test_ok_from_ast "some" option_env some;
|
||||||
|
|
Loading…
Reference in New Issue