balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch '8-reporting-of-error-messages' of gitlab.com:ligolang/ligo into 8-reporting-of-error-messages

Browse Source
This commit is contained in:
Christian Rinderknecht 2019-06-04 16:12:39 +02:00
commit 358b2fda83
1 changed files with 102 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

172
src/typer/typer.ml
View File

@ -16,106 +16,123 @@ module Errors = struct
let message () = "" in let message () = "" in
let data = [ let data = [
("variable" , fun () -> Format.asprintf "%s" n) ; ("variable" , fun () -> Format.asprintf "%s" n) ;
(* TODO: types don't have srclocs for now. *)
(* ("location" , fun () -> Format.asprintf "%a" Location.pp (n.location)) ; *)
("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("in" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e)
] in ] in
error ~data title message () error ~data title message ()
let unbound_variable (e:environment) (n:string) () = let unbound_variable (e:environment) (n:string) (loc:Location.t) () =
let title = (thunk "unbound variable") in let title = (thunk "unbound variable") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variable" , fun () -> Format.asprintf "%s" n) ; ("variable" , fun () -> Format.asprintf "%s" n) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let match_empty_variant : type a . a I.matching -> unit -> _ = let match_empty_variant : type a . a I.matching -> Location.t -> unit -> _ =
fun matching () -> fun matching loc () ->
let title = (thunk "match with no cases") in let title = (thunk "match with no cases") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let match_missing_case : type a . a I.matching -> unit -> _ = let match_missing_case : type a . a I.matching -> Location.t -> unit -> _ =
fun matching () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let match_redundant_case : type a . a I.matching -> unit -> _ = let match_redundant_case : type a . a I.matching -> Location.t -> unit -> _ =
fun matching () -> fun matching loc () ->
let title = (thunk "missing case in match") in let title = (thunk "missing case in match") in
let message () = "" in let message () = "" in
let data = [ let data = [
("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ("variant" , fun () -> Format.asprintf "%a" I.PP.matching_type matching) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let unbound_constructor (e:environment) (n:string) () = let unbound_constructor (e:environment) (n:string) (loc:Location.t) () =
let title = (thunk "unbound constructor") in let title = (thunk "unbound constructor") in
let message () = "" in let message () = "" in
let data = [ let data = [
("constructor" , fun () -> Format.asprintf "%s" n) ; ("constructor" , fun () -> Format.asprintf "%s" n) ;
("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ("environment" , fun () -> Format.asprintf "%a" Environment.PP.full_environment e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let unrecognized_constant (n:string) () = let unrecognized_constant (n:string) (loc:Location.t) () =
let title = (thunk "unrecognized constant") in let title = (thunk "unrecognized constant") in
let message () = "" in let message () = "" in
let data = [ let data = [
("constant" , fun () -> Format.asprintf "%s" n) ; ("constant" , fun () -> Format.asprintf "%s" n) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let wrong_arity (n:string) (expected:int) (actual:int) () = let wrong_arity (n:string) (expected:int) (actual:int) (loc : Location.t) () =
let title () = "wrong arity" in let title () = "wrong arity" in
let message () = "" in let message () = "" in
let data = [ let data = [
("function" , fun () -> Format.asprintf "%s" n) ; ("function" , fun () -> Format.asprintf "%s" n) ;
("expected" , fun () -> Format.asprintf "%d" expected) ; ("expected" , fun () -> Format.asprintf "%d" expected) ;
("actual" , fun () -> Format.asprintf "%d" actual) ("actual" , fun () -> Format.asprintf "%d" actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let match_tuple_wrong_arity (expected:'a list) (actual:'b list) () = let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () =
let title () = "matching tuple of different size" in let title () = "matching tuple of different size" in
let message () = "" in let message () = "" in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ; ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ;
("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
(* TODO: this should be a trace_info? *)
let program_error (p:I.program) () = let program_error (p:I.program) () =
let message () = "" in let message () = "" in
let title = (thunk "typing program") in let title = (thunk "typing program") in
let data = [ let data = [
"program" , fun () -> Format.asprintf "%a" I.PP.program p ("program" , fun () -> Format.asprintf "%a" I.PP.program p)
] in ] in
error ~data title message () error ~data title message ()
let constant_declaration_error (name:string) (ae:I.expr) () = let constant_declaration_error (name:string) (ae:I.expr) (expected: O.type_value option) () =
let title = (thunk "typing constant declaration") in let title = (thunk "typing constant declaration") in
let message () = "" in let message () = "" in
let data = [ let data = [
("constant" , fun () -> Format.asprintf "%s" name) ; ("constant" , fun () -> Format.asprintf "%s" name) ;
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("expected" , fun () ->
match expected with
None -> "(no annotation for the expected type)"
| Some expected -> Format.asprintf "%a" O.PP.type_value expected) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in ] in
error ~data title message () error ~data title message ()
let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> unit -> _ = let match_error : type a . ?msg:string -> expected: a I.matching -> actual: O.type_value -> Location.t -> unit -> _ =
fun ?(msg = "") ~expected ~actual () -> fun ?(msg = "") ~expected ~actual loc () ->
let title = (thunk "typing match") in let title = (thunk "typing match") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected); ("expected" , fun () -> Format.asprintf "%a" I.PP.matching_type expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
@ -123,47 +140,52 @@ module Errors = struct
let title = (thunk "this expression must be annotated with its type") in let title = (thunk "this expression must be annotated with its type") in
let message () = Format.asprintf "%s needs an annotation" case in let message () = Format.asprintf "%s needs an annotation" case in
let data = [ let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ("expression" , fun () -> Format.asprintf "%a" I.PP.expression e) ;
("location" , fun () -> Format.asprintf "%a" Location.pp e.location)
] in ] in
error ~data title message () error ~data title message ()
let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) () = let type_error_approximate ?(msg="") ~(expected: string) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
let title = (thunk "type error") in let title = (thunk "type error") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%s" expected); ("expected" , fun () -> Format.asprintf "%s" expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) () = let type_error ?(msg="") ~(expected: O.type_value) ~(actual: O.type_value) ~(expression : O.value) (loc:Location.t) () =
let title = (thunk "type error") in let title = (thunk "type error") in
let message () = msg in let message () = msg in
let data = [ let data = [
("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected); ("expected" , fun () -> Format.asprintf "%a" O.PP.type_value expected);
("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual); ("actual" , fun () -> Format.asprintf "%a" O.PP.type_value actual);
("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ("expression" , fun () -> Format.asprintf "%a" O.PP.value expression) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) () = let bad_tuple_index (index : int) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid tuple index") in let title = (thunk "invalid tuple index") in
let message () = "" in let message () = "" in
let data = [ let data = [
("index" , fun () -> Format.asprintf "%d" index) ; ("index" , fun () -> Format.asprintf "%d" index) ;
("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; ("tuple_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) () = let bad_record_access (field : string) (ae : I.expression) (t : O.type_value) (loc:Location.t) () =
let title = (thunk "invalid record field") in let title = (thunk "invalid record field") in
let message () = "" in let message () = "" in
let data = [ let data = [
("field" , fun () -> Format.asprintf "%s" field) ; ("field" , fun () -> Format.asprintf "%s" field) ;
("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ; ("record_value" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ("tuple_type" , fun () -> Format.asprintf "%a" O.PP.type_value t) ;
("location" , fun () -> Format.asprintf "%a" Location.pp loc)
] in ] in
error ~data title message () error ~data title message ()
@ -171,7 +193,8 @@ module Errors = struct
let title = (thunk "not suported yet") in let title = (thunk "not suported yet") in
let message () = message in let message () = message in
let data = [ let data = [
("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ("expression" , fun () -> Format.asprintf "%a" I.PP.expression ae) ;
("location" , fun () -> Format.asprintf "%a" Location.pp ae.location)
] in ] in
error ~data title message () error ~data title message ()
@ -208,24 +231,24 @@ and type_declaration env : I.declaration -> (environment * O.declaration option)
| Declaration_constant (name , tv_opt , expression) -> ( | Declaration_constant (name , tv_opt , expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind ae' = let%bind ae' =
trace (constant_declaration_error name expression) @@ trace (constant_declaration_error name expression tv'_opt) @@
type_expression ?tv_opt:tv'_opt env expression in type_expression ?tv_opt:tv'_opt env expression in
let env' = Environment.add_ez_ae name ae' env in let env' = Environment.add_ez_ae name ae' env in
ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env')))) ok (env', Some (O.Declaration_constant ((make_n_e name ae') , (env , env'))))
) )
and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result = and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> Location.t -> o O.matching result =
fun f e t i -> match i with fun f e t i loc -> match i with
| Match_bool {match_true ; match_false} -> | Match_bool {match_true ; match_false} ->
let%bind _ = let%bind _ =
trace_strong (match_error ~expected:i ~actual:t) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_bool t in @@ get_t_bool t in
let%bind match_true = f e match_true in let%bind match_true = f e match_true in
let%bind match_false = f e match_false in let%bind match_false = f e match_false in
ok (O.Match_bool {match_true ; match_false}) ok (O.Match_bool {match_true ; match_false})
| Match_option {match_none ; match_some} -> | Match_option {match_none ; match_some} ->
let%bind t_opt = let%bind t_opt =
trace_strong (match_error ~expected:i ~actual:t) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_option t in @@ get_t_option t in
let%bind match_none = f e match_none in let%bind match_none = f e match_none in
let (n, b) = match_some in let (n, b) = match_some in
@ -235,7 +258,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
ok (O.Match_option {match_none ; match_some = (n', b')}) ok (O.Match_option {match_none ; match_some = (n', b')})
| Match_list {match_nil ; match_cons} -> | Match_list {match_nil ; match_cons} ->
let%bind t_list = let%bind t_list =
trace_strong (match_error ~expected:i ~actual:t) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_list t in @@ get_t_list t in
let%bind match_nil = f e match_nil in let%bind match_nil = f e match_nil in
let (hd, tl, b) = match_cons in let (hd, tl, b) = match_cons in
@ -245,10 +268,10 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')}) ok (O.Match_list {match_nil ; match_cons = (hd, tl, b')})
| Match_tuple (lst, b) -> | Match_tuple (lst, b) ->
let%bind t_tuple = let%bind t_tuple =
trace_strong (match_error ~expected:i ~actual:t) trace_strong (match_error ~expected:i ~actual:t loc)
@@ get_t_tuple t in @@ get_t_tuple t in
let%bind lst' = let%bind lst' =
generic_try (match_tuple_wrong_arity t_tuple lst) generic_try (match_tuple_wrong_arity t_tuple lst loc)
@@ (fun () -> List.combine lst t_tuple) in @@ (fun () -> List.combine lst t_tuple) in
let aux prev (name, tv) = Environment.add_ez_binder name tv prev in let aux prev (name, tv) = Environment.add_ez_binder name tv prev in
let e' = List.fold_left aux e lst' in let e' = List.fold_left aux e lst' in
@ -258,7 +281,7 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
let%bind variant_opt = let%bind variant_opt =
let aux acc ((constructor_name , _) , _) = let aux acc ((constructor_name , _) , _) =
let%bind (_ , variant) = let%bind (_ , variant) =
trace_option (unbound_constructor e constructor_name) @@ trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in Environment.get_constructor constructor_name e in
let%bind acc = match acc with let%bind acc = match acc with
| None -> ok (Some variant) | None -> ok (Some variant)
@ -270,11 +293,11 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
trace (simple_info "in match variant") @@ trace (simple_info "in match variant") @@
bind_fold_list aux None lst in bind_fold_list aux None lst in
let%bind variant = let%bind variant =
trace_option (match_empty_variant i) @@ trace_option (match_empty_variant i loc) @@
variant_opt in variant_opt in
let%bind () = let%bind () =
let%bind variant_cases' = let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t) trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum variant in @@ Ast_typed.Combinators.get_t_sum variant in
let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in let variant_cases = List.map fst @@ Map.String.to_kv_list variant_cases' in
let match_cases = List.map (Function.compose fst fst) lst in let match_cases = List.map (Function.compose fst fst) lst in
@ -282,17 +305,17 @@ and type_match : type i o . (environment -> i -> o result) -> environment -> O.t
Assert.assert_true (List.mem c match_cases) Assert.assert_true (List.mem c match_cases)
in in
let%bind () = let%bind () =
trace_strong (match_missing_case i) @@ trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in bind_iter_list test_case variant_cases in
let%bind () = let%bind () =
trace_strong (match_redundant_case i) @@ trace_strong (match_redundant_case i loc) @@
Assert.assert_true List.(length variant_cases = length match_cases) in Assert.assert_true List.(length variant_cases = length match_cases) in
ok () ok ()
in in
let%bind lst' = let%bind lst' =
let aux ((constructor_name , name) , b) = let aux ((constructor_name , name) , b) =
let%bind (constructor , _) = let%bind (constructor , _) =
trace_option (unbound_constructor e constructor_name) @@ trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in Environment.get_constructor constructor_name e in
let e' = Environment.add_ez_binder name constructor e in let e' = Environment.add_ez_binder name constructor e in
let%bind b' = f e' b in let%bind b' = f e' b in
@ -361,7 +384,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
| E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword" | E_failwith _ -> fail @@ needs_annotation ae "the failwith keyword"
| E_variable name -> | E_variable name ->
let%bind tv' = let%bind tv' =
trace_option (unbound_variable e name) trace_option (unbound_variable e name ae.location)
@@ Environment.get_opt name e in @@ Environment.get_opt name e in
return (E_variable name) tv'.type_value return (E_variable name) tv'.type_value
| E_literal (Literal_bool b) -> | E_literal (Literal_bool b) ->
@ -391,30 +414,30 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
let%bind lst' = bind_list @@ List.map (type_expression e) lst in let%bind lst' = bind_list @@ List.map (type_expression e) lst in
let tv_lst = List.map get_type_annotation lst' in let tv_lst = List.map get_type_annotation lst' in
return (E_tuple lst') (t_tuple tv_lst ()) return (E_tuple lst') (t_tuple tv_lst ())
| E_accessor (ae, path) -> | E_accessor (ae', path) ->
let%bind e' = type_expression e ae in let%bind e' = type_expression e ae' in
let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result = let aux (prev:O.annotated_expression) (a:I.access) : O.annotated_expression result =
match a with match a with
| Access_tuple index -> ( | Access_tuple index -> (
let%bind tpl_tv = get_t_tuple prev.type_annotation in let%bind tpl_tv = get_t_tuple prev.type_annotation in
let%bind tv = let%bind tv =
generic_try (bad_tuple_index index ae prev.type_annotation) generic_try (bad_tuple_index index ae' prev.type_annotation ae.location)
@@ (fun () -> List.nth tpl_tv index) in @@ (fun () -> List.nth tpl_tv index) in
return (E_tuple_accessor (prev , index)) tv return (E_tuple_accessor (prev , index)) tv
) )
| Access_record property -> ( | Access_record property -> (
let%bind r_tv = get_t_record prev.type_annotation in let%bind r_tv = get_t_record prev.type_annotation in
let%bind tv = let%bind tv =
generic_try (bad_record_access property ae prev.type_annotation) generic_try (bad_record_access property ae' prev.type_annotation ae.location)
@@ (fun () -> SMap.find property r_tv) in @@ (fun () -> SMap.find property r_tv) in
return (E_record_accessor (prev , property)) tv return (E_record_accessor (prev , property)) tv
) )
| Access_map ae -> ( | Access_map ae' -> (
let%bind ae' = type_expression e ae in let%bind ae'' = type_expression e ae' in
let%bind (k , v) = get_t_map prev.type_annotation in let%bind (k , v) = get_t_map prev.type_annotation in
let%bind () = let%bind () =
Ast_typed.assert_type_value_eq (k , get_type_annotation ae') in Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in
return (E_look_up (prev , ae')) v return (E_look_up (prev , ae'')) v
) )
in in
trace (simple_info "accessing") @@ trace (simple_info "accessing") @@
@ -533,7 +556,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
| E_constant (name, lst) -> | E_constant (name, lst) ->
let%bind lst' = bind_list @@ List.map (type_expression e) lst in let%bind lst' = bind_list @@ List.map (type_expression e) lst in
let tv_lst = List.map get_type_annotation lst' in let tv_lst = List.map get_type_annotation lst' in
let%bind (name', tv) = type_constant name tv_lst tv_opt in let%bind (name', tv) = type_constant name tv_lst tv_opt ae.location in
return (E_constant (name' , lst')) tv return (E_constant (name' , lst')) tv
| E_application (f, arg) -> | E_application (f, arg) ->
let%bind f = type_expression e f in let%bind f = type_expression e f in
@ -547,6 +570,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
~expected:"should be a function type" ~expected:"should be a function type"
~expression:f ~expression:f
~actual:f.type_annotation ~actual:f.type_annotation
f.location
in in
return (E_application (f , arg)) tv return (E_application (f , arg)) tv
| E_look_up dsi -> | E_look_up dsi ->
@ -565,10 +589,14 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
let%bind mf' = type_expression e match_false in let%bind mf' = type_expression e match_false in
let t = get_type_annotation ex' in let t = get_type_annotation ex' in
let%bind () = let%bind () =
trace_strong (match_error ~expected:m ~actual:t) trace_strong (match_error ~expected:m ~actual:t ae.location)
@@ assert_t_bool t in @@ assert_t_bool t in
let%bind () = let%bind () =
trace_strong (match_error ~msg:"matching not-unit on an assert" ~expected:m ~actual:t) trace_strong (match_error
~msg:"matching not-unit on an assert"
~expected:m
~actual:t
ae.location)
@@ assert_t_unit (get_type_annotation mf') in @@ assert_t_unit (get_type_annotation mf') in
let mt' = make_a_e let mt' = make_a_e
(E_constant ("ASSERT" , [ex' ; fw'])) (E_constant ("ASSERT" , [ex' ; fw']))
@ -579,7 +607,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
return (O.E_matching (ex' , m')) (t_unit ()) return (O.E_matching (ex' , m')) (t_unit ())
) )
| _ -> ( | _ -> (
let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m in let%bind m' = type_match (type_expression ?tv_opt:None) e ex'.type_annotation m ae.location in
let tvs = let tvs =
let aux (cur:O.value O.matching) = let aux (cur:O.value O.matching) =
match cur with match cur with
@ -597,7 +625,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
ok (Some cur) in ok (Some cur) in
let%bind tv_opt = bind_fold_list aux None tvs in let%bind tv_opt = bind_fold_list aux None tvs in
let%bind tv = let%bind tv =
trace_option (match_empty_variant m) @@ trace_option (match_empty_variant m ae.location) @@
tv_opt in tv_opt in
return (O.E_matching (ex', m')) tv return (O.E_matching (ex', m')) tv
) )
@ -611,7 +639,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
~msg:"first part of the sequence should be of unit type" ~msg:"first part of the sequence should be of unit type"
~expected:(O.t_unit ()) ~expected:(O.t_unit ())
~actual:a'_type_annot ~actual:a'_type_annot
~expression:a') @@ ~expression:a'
a'.location) @@
Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in Ast_typed.assert_type_value_eq (t_unit () , a'_type_annot) in
return (O.E_sequence (a' , b')) (get_type_annotation b') return (O.E_sequence (a' , b')) (get_type_annotation b')
| E_loop (expr , body) -> | E_loop (expr , body) ->
@ -623,7 +652,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
~msg:"while condition isn't of type bool" ~msg:"while condition isn't of type bool"
~expected:(O.t_bool ()) ~expected:(O.t_bool ())
~actual:t_expr' ~actual:t_expr'
~expression:expr') @@ ~expression:expr'
expr'.location) @@
Ast_typed.assert_type_value_eq (t_bool () , t_expr') in Ast_typed.assert_type_value_eq (t_bool () , t_expr') in
let t_body' = get_type_annotation body' in let t_body' = get_type_annotation body' in
let%bind () = let%bind () =
@ -631,7 +661,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
~msg:"while body isn't of unit type" ~msg:"while body isn't of unit type"
~expected:(O.t_unit ()) ~expected:(O.t_unit ())
~actual:t_body' ~actual:t_body'
~expression:body') @@ ~expression:body'
body'.location) @@
Ast_typed.assert_type_value_eq (t_unit () , t_body') in Ast_typed.assert_type_value_eq (t_unit () , t_body') in
return (O.E_loop (expr' , body')) (t_unit ()) return (O.E_loop (expr' , body')) (t_unit ())
| E_assign (name , path , expr) -> | E_assign (name , path , expr) ->
@ -644,14 +675,14 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
| Access_tuple index -> ( | Access_tuple index -> (
let%bind tpl = get_t_tuple prec_tv in let%bind tpl = get_t_tuple prec_tv in
let%bind tv' = let%bind tv' =
trace_option (bad_tuple_index index ae prec_tv) @@ trace_option (bad_tuple_index index ae prec_tv ae.location) @@
List.nth_opt tpl index in List.nth_opt tpl index in
ok (tv' , prec_path @ [O.Access_tuple index]) ok (tv' , prec_path @ [O.Access_tuple index])
) )
| Access_record property -> ( | Access_record property -> (
let%bind m = get_t_record prec_tv in let%bind m = get_t_record prec_tv in
let%bind tv' = let%bind tv' =
trace_option (bad_record_access property ae prec_tv) @@ trace_option (bad_record_access property ae prec_tv ae.location) @@
Map.String.find_opt property m in Map.String.find_opt property m in
ok (tv' , prec_path @ [O.Access_record property]) ok (tv' , prec_path @ [O.Access_record property])
) )
@ -666,7 +697,8 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
~msg:"type of the expression to assign doesn't match left-hand-side" ~msg:"type of the expression to assign doesn't match left-hand-side"
~expected:assign_tv ~expected:assign_tv
~actual:t_expr' ~actual:t_expr'
~expression:expr') @@ ~expression:expr'
expr'.location) @@
Ast_typed.assert_type_value_eq (assign_tv , t_expr') in Ast_typed.assert_type_value_eq (assign_tv , t_expr') in
return (O.E_assign (typed_name , path' , expr')) (t_unit ()) return (O.E_assign (typed_name , path' , expr')) (t_unit ())
| E_let_in {binder ; rhs ; result} -> | E_let_in {binder ; rhs ; result} ->
@ -682,11 +714,11 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a
ok {expr' with type_annotation} ok {expr' with type_annotation}
and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) : (string * O.type_value) result = and type_constant (name:string) (lst:O.type_value list) (tv_opt:O.type_value option) (loc : Location.t) : (string * O.type_value) result =
(* Constant poorman's polymorphism *) (* Constant poorman's polymorphism *)
let ct = Operators.Typer.constant_typers in let ct = Operators.Typer.constant_typers in
let%bind typer = let%bind typer =
trace_option (unrecognized_constant name) @@ trace_option (unrecognized_constant name loc) @@
Map.String.find_opt name ct in Map.String.find_opt name ct in
typer lst tv_opt typer lst tv_opt