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

fix weird bug in matching cases

Browse Source
This commit is contained in:
Lesenechal Remi 2020-04-30 19:04:01 +02:00
parent 0a44a22cac
commit 8fdf9a8b95
1 changed files with 17 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
src/passes/8-typer-old/typer.ml
View File

@ -208,7 +208,7 @@ module Errors = struct
] in ] in
error ~data title message () error ~data title message ()
let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (loc:Location.t) () = let _type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_expression) ~(expression : I.expression) (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 = [
@ -551,59 +551,32 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ
let%bind body = f e' b in let%bind body = f e' b in
ok (O.Match_tuple { vars ; body ; tvs}) ok (O.Match_tuple { vars ; body ; tvs})
| Match_variant (lst,_) -> | Match_variant (lst,_) ->
let%bind variant_opt = let%bind variant_cases' =
let aux acc ((constructor_name , _) , _) = trace (match_error ~expected:i ~actual:t loc)
let%bind (_ , variant) = @@ Ast_typed.Combinators.get_t_sum t in
trace_option (unbound_constructor e constructor_name loc) @@ let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
Environment.get_constructor constructor_name e in let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let%bind acc = match acc with let test_case = fun c ->
| None -> ok (Some variant) Assert.assert_true (List.mem c match_cases)
| Some variant' -> (
trace (type_error
~msg:"in match variant"
~expected:variant
~actual:variant'
~expression:ae
loc
) @@
Ast_typed.assert_type_expression_eq (variant , variant') >>? fun () ->
ok (Some variant)
) in
ok acc in
trace (simple_info "in match variant") @@
bind_fold_list aux None lst in
let%bind tv =
trace_option (match_empty_variant i loc) @@
variant_opt in
let%bind () =
let%bind variant_cases' =
trace (match_error ~expected:i ~actual:t loc)
@@ Ast_typed.Combinators.get_t_sum tv in
let variant_cases = List.map fst @@ O.CMap.to_kv_list variant_cases' in
let match_cases = List.map (fun x -> convert_constructor' @@ fst @@ fst x) lst in
let test_case = fun c ->
Assert.assert_true (List.mem c match_cases)
in
let%bind () =
trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in
let%bind () =
trace_strong (match_redundant_case i loc) @@
Assert.assert_true List.(length variant_cases = length match_cases) in
ok ()
in in
let%bind () =
trace_strong (match_missing_case i loc) @@
bind_iter_list test_case variant_cases in
let%bind () =
trace_strong (match_redundant_case i loc) @@
Assert.assert_true List.(length variant_cases = length match_cases) in
let%bind cases = let%bind cases =
let aux ((constructor_name , pattern) , b) = let aux ((constructor_name , pattern) , b) =
let%bind (constructor , _) = let%bind {ctor_type=constructor;_} =
trace_option (unbound_constructor e constructor_name loc) @@ trace_option (unbound_constructor e constructor_name loc) @@
Environment.get_constructor constructor_name e in O.CMap.find_opt (convert_constructor' constructor_name) variant_cases' in
let e' = Environment.add_ez_binder pattern constructor e in let e' = Environment.add_ez_binder pattern constructor e in
let%bind body = f e' b in let%bind body = f e' b in
let constructor = convert_constructor' constructor_name in let constructor = convert_constructor' constructor_name in
ok ({constructor ; pattern ; body} : O.matching_content_case) ok ({constructor ; pattern ; body} : O.matching_content_case)
in in
bind_map_list aux lst in bind_map_list aux lst in
ok (O.Match_variant { cases ; tv }) ok (O.Match_variant { cases ; tv=t })
and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result = and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression result =
let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in let return tv' = ok (make_t ~loc:t.location tv' (Some t)) in