From 5896b2a63aebf7d44a7541de1323032e31238db9 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Thu, 4 Jun 2020 15:30:14 +0200 Subject: [PATCH] Add new matching cases and fix compilation of match_tuples --- .../02-concrete_to_imperative/cameligo.ml | 8 +- .../02-concrete_to_imperative/pascaligo.ml | 6 +- src/passes/03-self_ast_imperative/helpers.ml | 122 +++++++++++------- .../imperative_to_sugar.ml | 62 +++++---- src/passes/05-self_ast_sugar/helpers.ml | 122 +++++++++++------- src/passes/06-sugar_to_core/sugar_to_core.ml | 76 +++++++---- src/passes/07-self_ast_core/helpers.ml | 42 +++--- .../08-typer-new/todo_use_fold_generator.ml | 1 + src/passes/08-typer-new/typer.ml | 18 +-- src/passes/08-typer-new/untyper.ml | 13 +- src/passes/08-typer-old/typer.ml | 40 +----- src/passes/09-self_ast_typed/helpers.ml | 12 -- .../09-self_ast_typed/tail_recursion.ml | 3 - src/passes/10-transpiler/transpiler.ml | 12 -- src/stages/1-ast_imperative/PP.ml | 26 ++-- src/stages/1-ast_imperative/combinators.ml | 7 +- src/stages/1-ast_imperative/combinators.mli | 5 +- src/stages/1-ast_imperative/types.ml | 15 ++- src/stages/2-ast_sugar/PP.ml | 26 ++-- src/stages/2-ast_sugar/types.ml | 15 ++- src/stages/3-ast_core/PP.ml | 16 +-- src/stages/3-ast_core/combinators.ml | 2 +- src/stages/3-ast_core/combinators.mli | 2 +- src/stages/3-ast_core/types.ml | 12 +- src/stages/4-ast_typed/PP.ml | 2 - src/stages/4-ast_typed/ast.ml | 7 - src/stages/4-ast_typed/compute_environment.ml | 15 --- src/stages/4-ast_typed/misc.ml | 2 - src/stages/4-ast_typed/misc_smart.ml | 2 - src/stages/common/ast_common.ml | 2 + src/stages/common/types.ml | 13 +- 31 files changed, 369 insertions(+), 337 deletions(-) diff --git a/src/passes/02-concrete_to_imperative/cameligo.ml b/src/passes/02-concrete_to_imperative/cameligo.ml index 9df82adb1..04ac16fe0 100644 --- a/src/passes/02-concrete_to_imperative/cameligo.ml +++ b/src/passes/02-concrete_to_imperative/cameligo.ml @@ -960,7 +960,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ) -and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_content result = +and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fun t -> let open Raw in let rec get_var (t:Raw.pattern) = @@ -1031,7 +1031,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten match patterns with | [(PFalse _, f) ; (PTrue _, t)] | [(PTrue _, t) ; (PFalse _, f)] -> - ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ()) + ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)]) | [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)] | [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] -> let%bind () = @@ -1044,7 +1044,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten let%bind a = get_var a in let%bind b = get_var b in ok (a, b) in - ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons, ()); match_nil=nil} + ok @@ Match_list {match_cons=(Var.of_name a, Var.of_name b, cons); match_nil=nil} | lst -> let error x = let title () = "Pattern" in @@ -1075,7 +1075,7 @@ and compile_cases : type a . (Raw.pattern * a) list -> (a, unit) matching_conten | [ (("None", None), none_expr); (("Some", Some some_var), some_expr) ] -> ok @@ Match_option { - match_some = (Var.of_name some_var, some_expr, ()); + match_some = (Var.of_name some_var, some_expr); match_none = none_expr } | _ -> simple_fail "bad option pattern" in bind_or (as_option () , as_variant ()) diff --git a/src/passes/02-concrete_to_imperative/pascaligo.ml b/src/passes/02-concrete_to_imperative/pascaligo.ml index b0c2820f3..9b653c280 100644 --- a/src/passes/02-concrete_to_imperative/pascaligo.ml +++ b/src/passes/02-concrete_to_imperative/pascaligo.ml @@ -1059,14 +1059,14 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu match patterns with | [(PConstr PFalse _ , f) ; (PConstr PTrue _ , t)] | [(PConstr PTrue _ , t) ; (PConstr PFalse _ , f)] -> - ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)], ()) + ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)]) | [(PConstr PSomeApp v , some) ; (PConstr PNone _ , none)] | [(PConstr PNone _ , none) ; (PConstr PSomeApp v , some)] -> ( let (_, v) = v.value in let%bind v = match v.value.inside with | PVar v -> ok v.value | p -> fail @@ unsupported_deep_Some_patterns p in - ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some, ()) } + ok @@ Match_option {match_none = none ; match_some = (Var.of_name v, some) } ) | [(PList PCons c, cons) ; (PList (PNil _), nil)] | [(PList (PNil _), nil) ; (PList PCons c, cons)] -> @@ -1079,7 +1079,7 @@ and compile_cases : (Raw.pattern * expression) list -> matching_expr result = fu | _ -> fail @@ unsupported_deep_list_patterns c in - ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons,()) ; match_nil = nil} + ok @@ Match_list {match_cons = (Var.of_name a, Var.of_name b, cons) ; match_nil = nil} | lst -> trace (simple_info "currently, only booleans, options, lists and \ user-defined constructors are supported in patterns") @@ diff --git a/src/passes/03-self_ast_imperative/helpers.ml b/src/passes/03-self_ast_imperative/helpers.ml index 018219a78..6a0d90946 100644 --- a/src/passes/03-self_ast_imperative/helpers.ml +++ b/src/passes/03-self_ast_imperative/helpers.ml @@ -114,31 +114,37 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self res body in ok res - - and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( - let%bind res = fold_expression f init match_nil in - let%bind res = fold_expression f res cons in - ok res - ) - | Match_option { match_none ; match_some = (_ , some, _) } -> ( - let%bind res = fold_expression f init match_none in - let%bind res = fold_expression f res some in - ok res - ) - | Match_tuple ((_ , e), _) -> ( - let%bind res = fold_expression f init e in - ok res - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init' ((_ , _) , e) = let%bind res' = fold_expression f init' e in ok res' in let%bind res = bind_fold_list aux init lst in ok res ) + | Match_list { match_nil ; match_cons = (_ , _ , cons) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_record (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_tuple (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variable (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) type exp_mapper = expression -> expression result type ty_exp_mapper = type_expression -> type_expression result @@ -284,27 +290,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( - let%bind match_nil = map_expression f match_nil in - let%bind cons = map_expression f cons in - ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) } - ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( - let%bind match_none = map_expression f match_none in - let%bind some = map_expression f some in - ok @@ Match_option { match_none ; match_some = (name , some, ()) } - ) - | Match_tuple ((names , e), _) -> ( - let%bind e' = map_expression f e in - ok @@ Match_tuple ((names , e'), []) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux ((a , b) , e) = let%bind e' = map_expression f e in ok ((a , b) , e') in let%bind lst' = bind_map_list aux lst in - ok @@ Match_variant (lst', ()) + ok @@ Match_variant lst' + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( + let%bind match_nil = map_expression f match_nil in + let%bind cons = map_expression f cons in + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) } + ) + | Match_option { match_none ; match_some = (name , some) } -> ( + let%bind match_none = map_expression f match_none in + let%bind some = map_expression f some in + ok @@ Match_option { match_none ; match_some = (name , some) } + ) + | Match_record (names, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_record (names, ty_opt, e') + ) + | Match_tuple (names, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple (names, ty_opt, e') + ) + | Match_variable (name, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_variable (name, ty_opt, e') ) and map_program : abs_mapper -> program -> program result = fun m p -> @@ -440,25 +454,33 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( - let%bind (init, match_nil) = fold_map_expression f init match_nil in - let%bind (init, cons) = fold_map_expression f init cons in - ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }) - ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( - let%bind (init, match_none) = fold_map_expression f init match_none in - let%bind (init, some) = fold_map_expression f init some in - ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) }) - ) - | Match_tuple ((names , e), _) -> ( - let%bind (init, e') = fold_map_expression f init e in - ok @@ (init, Match_tuple ((names , e'), [])) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init ((a , b) , e) = let%bind (init,e') = fold_map_expression f init e in ok (init, ((a , b) , e')) in let%bind (init,lst') = bind_fold_map_list aux init lst in - ok @@ (init, Match_variant (lst', ())) - ) + ok @@ (init, Match_variant lst') + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( + let%bind (init, match_nil) = fold_map_expression f init match_nil in + let%bind (init, cons) = fold_map_expression f init cons in + ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) }) + ) + | Match_option { match_none ; match_some = (name , some) } -> ( + let%bind (init, match_none) = fold_map_expression f init match_none in + let%bind (init, some) = fold_map_expression f init some in + ok @@ (init, Match_option { match_none ; match_some = (name , some) }) + ) + | Match_record (names, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_record (names, ty_opt, e')) + ) + | Match_tuple (names, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_tuple (names, ty_opt, e')) + ) + | Match_variable (name, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_variable (name, ty_opt, e')) + ) diff --git a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml index 4017db346..b9604aedc 100644 --- a/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/04-imperative_to_sugar/imperative_to_sugar.ml @@ -365,7 +365,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp match cases with | I.Match_option {match_none;match_some} -> let%bind match_none' = compile_expression match_none in - let (n,expr,tv) = match_some in + let (n,expr) = match_some in let%bind expr' = compile_expression expr in let env = Var.fresh () in let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in @@ -374,7 +374,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp let expr = add_to_end expr (O.e_variable env) in let free_vars = List.sort_uniq Var.compare @@ free_vars_none @ free_vars_some in if (List.length free_vars != 0) then - let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr,tv)}) in + let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in let return_expr = fun expr -> O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@ O.e_let_in (env,None) false false match_expr @@ @@ -382,19 +382,19 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp in ok @@ restore_mutable_variable return_expr free_vars env else - return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)} + return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr')} | I.Match_list {match_nil;match_cons} -> let%bind match_nil' = compile_expression match_nil in - let (hd,tl,expr,tv) = match_cons in + let (hd,tl,expr) = match_cons in let%bind expr' = compile_expression expr in let env = Var.fresh () in let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env in let%bind ((_,free_vars_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in let match_nil = add_to_end match_nil (O.e_variable env) in - let expr = add_to_end expr (O.e_variable env) in + let expr = add_to_end expr (O.e_variable env) in let free_vars = List.sort_uniq Var.compare @@ free_vars_nil @ free_vars_cons in if (List.length free_vars != 0) then - let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)}) in + let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in let return_expr = fun expr -> O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@ O.e_let_in (env,None) false false match_expr @@ @@ -402,11 +402,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp in ok @@ restore_mutable_variable return_expr free_vars env else - return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)} - | I.Match_tuple ((lst,expr), tv) -> - let%bind expr = compile_expression expr in - return @@ O.e_matching ~loc matchee @@ O.Match_tuple ((lst,expr), tv) - | I.Match_variant (lst,tv) -> + return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')} + | I.Match_variant lst -> let env = Var.fresh () in let aux fv ((c,n),expr) = let%bind expr = compile_expression expr in @@ -418,10 +415,10 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp let free_vars = List.sort_uniq Var.compare @@ List.concat fv in if (List.length free_vars == 0) then ( let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in - return @@ O.e_matching ~loc matchee @@ O.Match_variant (cases,tv) + return @@ O.e_matching ~loc matchee @@ O.Match_variant cases ) else ( let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in - let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in + let match_expr = O.e_matching matchee @@ O.Match_variant cases in let return_expr = fun expr -> O.e_let_in (env,None) false false (store_mutable_variable free_vars) @@ O.e_let_in (env,None) false false match_expr @@ @@ -429,6 +426,18 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp in ok @@ restore_mutable_variable return_expr free_vars env ) + | I.Match_record (lst,ty_opt,expr) -> + let%bind expr = compile_expression expr in + let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in + return @@ O.e_matching ~loc matchee @@ O.Match_record (lst,ty_opt,expr) + | I.Match_tuple (lst,ty_opt,expr) -> + let%bind expr = compile_expression expr in + let%bind ty_opt = bind_map_option (bind_map_list compile_type_expression) ty_opt in + return @@ O.e_matching ~loc matchee @@ O.Match_tuple (lst,ty_opt,expr) + | I.Match_variable (lst,ty_opt,expr) -> + let%bind expr = compile_expression expr in + let%bind ty_opt = bind_map_option compile_type_expression ty_opt in + return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr) and compile_while I.{condition;body} = let env_rec = Var.fresh () in @@ -707,22 +716,31 @@ and uncompile_matching : O.matching_expr -> I.matching_expr result = match m with | O.Match_list {match_nil;match_cons} -> let%bind match_nil = uncompile_expression' match_nil in - let (hd,tl,expr,tv) = match_cons in + let (hd,tl,expr) = match_cons in let%bind expr = uncompile_expression' expr in - ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)} | O.Match_option {match_none;match_some} -> let%bind match_none = uncompile_expression' match_none in - let (n,expr,tv) = match_some in + let (n,expr) = match_some in let%bind expr = uncompile_expression' expr in - ok @@ I.Match_option {match_none; match_some=(n,expr,tv)} - | O.Match_tuple ((lst,expr), tv) -> - let%bind expr = uncompile_expression' expr in - ok @@ O.Match_tuple ((lst,expr), tv) - | O.Match_variant (lst,tv) -> + ok @@ I.Match_option {match_none; match_some=(n,expr)} + | O.Match_variant lst -> let%bind lst = bind_map_list ( fun ((c,n),expr) -> let%bind expr = uncompile_expression' expr in ok @@ ((c,n),expr) ) lst in - ok @@ I.Match_variant (lst,tv) + ok @@ I.Match_variant lst + | O.Match_record (lst,ty_opt,expr) -> + let%bind expr = uncompile_expression' expr in + let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in + ok @@ I.Match_record (lst,ty_opt,expr) + | O.Match_tuple (lst,ty_opt,expr) -> + let%bind expr = uncompile_expression' expr in + let%bind ty_opt = bind_map_option (bind_map_list uncompile_type_expression) ty_opt in + ok @@ I.Match_tuple (lst,ty_opt,expr) + | O.Match_variable (lst,ty_opt,expr) -> + let%bind expr = uncompile_expression' expr in + let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in + ok @@ I.Match_variable (lst,ty_opt,expr) diff --git a/src/passes/05-self_ast_sugar/helpers.ml b/src/passes/05-self_ast_sugar/helpers.ml index 953a8910f..bb8b37fb7 100644 --- a/src/passes/05-self_ast_sugar/helpers.ml +++ b/src/passes/05-self_ast_sugar/helpers.ml @@ -100,30 +100,37 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini ok res ) - and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( - let%bind res = fold_expression f init match_nil in - let%bind res = fold_expression f res cons in - ok res - ) - | Match_option { match_none ; match_some = (_ , some, _) } -> ( - let%bind res = fold_expression f init match_none in - let%bind res = fold_expression f res some in - ok res - ) - | Match_tuple ((_ , e), _) -> ( - let%bind res = fold_expression f init e in - ok res - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init' ((_ , _) , e) = let%bind res' = fold_expression f init' e in ok res' in let%bind res = bind_fold_list aux init lst in ok res ) + | Match_list { match_nil ; match_cons = (_ , _ , cons) } -> ( + let%bind res = fold_expression f init match_nil in + let%bind res = fold_expression f res cons in + ok res + ) + | Match_option { match_none ; match_some = (_ , some) } -> ( + let%bind res = fold_expression f init match_none in + let%bind res = fold_expression f res some in + ok res + ) + | Match_record (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_tuple (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) + | Match_variable (_, _, e) -> ( + let%bind res = fold_expression f init e in + ok res + ) type exp_mapper = expression -> expression result type ty_exp_mapper = type_expression -> type_expression result @@ -250,27 +257,35 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( - let%bind match_nil = map_expression f match_nil in - let%bind cons = map_expression f cons in - ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) } - ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( - let%bind match_none = map_expression f match_none in - let%bind some = map_expression f some in - ok @@ Match_option { match_none ; match_some = (name , some, ()) } - ) - | Match_tuple ((names , e), _) -> ( - let%bind e' = map_expression f e in - ok @@ Match_tuple ((names , e'), []) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux ((a , b) , e) = let%bind e' = map_expression f e in ok ((a , b) , e') in let%bind lst' = bind_map_list aux lst in - ok @@ Match_variant (lst', ()) + ok @@ Match_variant lst' + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( + let%bind match_nil = map_expression f match_nil in + let%bind cons = map_expression f cons in + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) } + ) + | Match_option { match_none ; match_some = (name , some) } -> ( + let%bind match_none = map_expression f match_none in + let%bind some = map_expression f some in + ok @@ Match_option { match_none ; match_some = (name , some) } + ) + | Match_record (names, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_record (names, ty_opt, e') + ) + | Match_tuple (names, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_tuple (names, ty_opt, e') + ) + | Match_variable (name, ty_opt, e) -> ( + let%bind e' = map_expression f e in + ok @@ Match_variable (name, ty_opt, e') ) and map_program : abs_mapper -> program -> program result = fun m p -> @@ -389,28 +404,35 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres ok (res, return @@ E_sequence {expr1;expr2}) ) | E_literal _ | E_variable _ | E_skip as e' -> ok (init', return e') - and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( - let%bind (init, match_nil) = fold_map_expression f init match_nil in - let%bind (init, cons) = fold_map_expression f init cons in - ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }) - ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( - let%bind (init, match_none) = fold_map_expression f init match_none in - let%bind (init, some) = fold_map_expression f init some in - ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) }) - ) - | Match_tuple ((names , e), _) -> ( - let%bind (init, e') = fold_map_expression f init e in - ok @@ (init, Match_tuple ((names , e'), [])) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init ((a , b) , e) = let%bind (init,e') = fold_map_expression f init e in ok (init, ((a , b) , e')) in let%bind (init,lst') = bind_fold_map_list aux init lst in - ok @@ (init, Match_variant (lst', ())) - ) + ok @@ (init, Match_variant lst') + ) + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( + let%bind (init, match_nil) = fold_map_expression f init match_nil in + let%bind (init, cons) = fold_map_expression f init cons in + ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) }) + ) + | Match_option { match_none ; match_some = (name , some) } -> ( + let%bind (init, match_none) = fold_map_expression f init match_none in + let%bind (init, some) = fold_map_expression f init some in + ok @@ (init, Match_option { match_none ; match_some = (name , some) }) + ) + | Match_record (names, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_record (names, ty_opt, e')) + ) + | Match_tuple (names, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_tuple (names, ty_opt, e')) + ) + | Match_variable (name, ty_opt, e) -> ( + let%bind (init, e') = fold_map_expression f init e in + ok @@ (init, Match_variable (name, ty_opt, e')) + ) diff --git a/src/passes/06-sugar_to_core/sugar_to_core.ml b/src/passes/06-sugar_to_core/sugar_to_core.ml index 3a106a3ce..ba6e8f441 100644 --- a/src/passes/06-sugar_to_core/sugar_to_core.ml +++ b/src/passes/06-sugar_to_core/sugar_to_core.ml @@ -76,8 +76,7 @@ let rec compile_expression : I.expression -> O.expression result = return @@ O.E_constructor {constructor;element} | I.E_matching {matchee; cases} -> let%bind matchee = compile_expression matchee in - let%bind cases = compile_matching cases in - return @@ O.E_matching {matchee;cases} + compile_matching e.location matchee cases | I.E_record record -> let record = I.LMap.to_kv_list record in let%bind record = @@ -137,7 +136,7 @@ let rec compile_expression : I.expression -> O.expression result = let%bind matchee = compile_expression condition in let%bind match_true = compile_expression then_clause in let%bind match_false = compile_expression else_clause in - return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)],())} + return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)])} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in @@ -166,30 +165,64 @@ and compile_lambda : I.lambda -> O.lambda result = let%bind output_type = bind_map_option idle_type_expression output_type in let%bind result = compile_expression result in ok @@ O.{binder;input_type;output_type;result} -and compile_matching : I.matching_expr -> O.matching_expr result = - fun m -> +and compile_matching : Location.t -> O.expression -> I.matching_expr -> O.expression result = + fun loc e m -> match m with | I.Match_list {match_nil;match_cons} -> let%bind match_nil = compile_expression match_nil in - let (hd,tl,expr,tv) = match_cons in + let (hd,tl,expr) = match_cons in let%bind expr = compile_expression expr in - ok @@ O.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + ok @@ O.e_matching ~loc e @@ O.Match_list {match_nil; match_cons=(hd,tl,expr)} | I.Match_option {match_none;match_some} -> let%bind match_none = compile_expression match_none in - let (n,expr,tv) = match_some in + let (n,expr) = match_some in let%bind expr = compile_expression expr in - ok @@ O.Match_option {match_none; match_some=(n,expr,tv)} - | I.Match_tuple ((lst,expr), tv) -> - let%bind expr = compile_expression expr in - ok @@ O.Match_tuple ((lst,expr), tv) - | I.Match_variant (lst,tv) -> + ok @@ O.e_matching ~loc e @@ O.Match_option {match_none; match_some=(n,expr)} + | I.Match_variant lst -> let%bind lst = bind_map_list ( fun ((c,n),expr) -> let%bind expr = compile_expression expr in ok @@ ((c,n),expr) ) lst in - ok @@ O.Match_variant (lst,tv) + ok @@ O.e_matching ~loc e @@ O.Match_variant lst + | I.Match_record (fields,field_types, expr) -> + let combine fields field_types = + match field_types with + Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft + | None -> List.map (fun x -> (x, None)) fields + in + let%bind next = compile_expression expr in + let%bind field_types = bind_map_option (bind_map_list idle_type_expression) field_types in + let aux ((index,expr) : int * _ ) ((field,name): (O.label * (O.expression_variable * O.type_expression option))) = + let f = fun expr' -> O.e_let_in name false (O.e_record_accessor e field) expr' in + (index+1, fun expr' -> expr (f expr')) + in + let (_,header) = List.fold_left aux (0, fun e -> e) @@ + List.map (fun ((a,b),c) -> (a,(b,c))) @@ + combine fields field_types + in + ok @@ header next + | I.Match_tuple (fields,field_types, expr) -> + let combine fields field_types = + match field_types with + Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft + | None -> List.map (fun x -> (x, None)) fields + in + let%bind next = compile_expression expr in + let%bind field_types = bind_map_option (bind_map_list idle_type_expression) field_types in + let aux ((index,expr) : int * _ ) (field: O.expression_variable * O.type_expression option) = + let f = fun expr' -> O.e_let_in field false (O.e_record_accessor e (Label (string_of_int index))) expr' in + (index+1, fun expr' -> expr (f expr')) + in + let (_,header) = List.fold_left aux (0, fun e -> e) @@ + combine fields field_types + in + ok @@ header next + | I.Match_variable (a, ty_opt, expr) -> + let%bind ty_opt = bind_map_option idle_type_expression ty_opt in + let%bind expr = compile_expression expr in + ok @@ O.e_let_in (a,ty_opt) false e expr let compile_declaration : I.declaration Location.wrap -> _ = fun {wrap_content=declaration;location} -> @@ -313,22 +346,19 @@ and uncompile_matching : O.matching_expr -> I.matching_expr result = match m with | O.Match_list {match_nil;match_cons} -> let%bind match_nil = uncompile_expression match_nil in - let (hd,tl,expr,tv) = match_cons in + let (hd,tl,expr) = match_cons in let%bind expr = uncompile_expression expr in - ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr,tv)} + ok @@ I.Match_list {match_nil; match_cons=(hd,tl,expr)} | O.Match_option {match_none;match_some} -> let%bind match_none = uncompile_expression match_none in - let (n,expr,tv) = match_some in + let (n,expr) = match_some in let%bind expr = uncompile_expression expr in - ok @@ I.Match_option {match_none; match_some=(n,expr,tv)} - | O.Match_tuple ((lst,expr), tv) -> - let%bind expr = uncompile_expression expr in - ok @@ O.Match_tuple ((lst,expr), tv) - | O.Match_variant (lst,tv) -> + ok @@ I.Match_option {match_none; match_some=(n,expr)} + | O.Match_variant lst -> let%bind lst = bind_map_list ( fun ((c,n),expr) -> let%bind expr = uncompile_expression expr in ok @@ ((c,n),expr) ) lst in - ok @@ I.Match_variant (lst,tv) + ok @@ I.Match_variant lst diff --git a/src/passes/07-self_ast_core/helpers.ml b/src/passes/07-self_ast_core/helpers.ml index d4311211e..572da1832 100644 --- a/src/passes/07-self_ast_core/helpers.ml +++ b/src/passes/07-self_ast_core/helpers.ml @@ -72,21 +72,17 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (_ , _ , cons, _) } -> ( + | Match_list { match_nil ; match_cons = (_ , _ , cons) } -> ( let%bind res = fold_expression f init match_nil in let%bind res = fold_expression f res cons in ok res ) - | Match_option { match_none ; match_some = (_ , some, _) } -> ( + | Match_option { match_none ; match_some = (_ , some) } -> ( let%bind res = fold_expression f init match_none in let%bind res = fold_expression f res some in ok res ) - | Match_tuple ((_ , e), _) -> ( - let%bind res = fold_expression f init e in - ok res - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init' ((_ , _) , e) = let%bind res' = fold_expression f init' e in ok res' in @@ -174,27 +170,23 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( let%bind match_nil = map_expression f match_nil in let%bind cons = map_expression f cons in - ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons, ()) } + ok @@ Match_list { match_nil ; match_cons = (hd , tl , cons) } ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( + | Match_option { match_none ; match_some = (name , some) } -> ( let%bind match_none = map_expression f match_none in let%bind some = map_expression f some in - ok @@ Match_option { match_none ; match_some = (name , some, ()) } + ok @@ Match_option { match_none ; match_some = (name , some) } ) - | Match_tuple ((names , e), _) -> ( - let%bind e' = map_expression f e in - ok @@ Match_tuple ((names , e'), []) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux ((a , b) , e) = let%bind e' = map_expression f e in ok ((a , b) , e') in let%bind lst' = bind_map_list aux lst in - ok @@ Match_variant (lst', ()) + ok @@ Match_variant lst' ) and map_program : abs_mapper -> program -> program result = fun m p -> @@ -274,25 +266,21 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres and fold_map_cases : 'a fold_mapper -> 'a -> matching_expr -> ('a * matching_expr) result = fun f init m -> match m with - | Match_list { match_nil ; match_cons = (hd , tl , cons, _) } -> ( + | Match_list { match_nil ; match_cons = (hd , tl , cons) } -> ( let%bind (init, match_nil) = fold_map_expression f init match_nil in let%bind (init, cons) = fold_map_expression f init cons in - ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons, ()) }) + ok @@ (init, Match_list { match_nil ; match_cons = (hd , tl , cons) }) ) - | Match_option { match_none ; match_some = (name , some, _) } -> ( + | Match_option { match_none ; match_some = (name , some) } -> ( let%bind (init, match_none) = fold_map_expression f init match_none in let%bind (init, some) = fold_map_expression f init some in - ok @@ (init, Match_option { match_none ; match_some = (name , some, ()) }) + ok @@ (init, Match_option { match_none ; match_some = (name , some) }) ) - | Match_tuple ((names , e), _) -> ( - let%bind (init, e') = fold_map_expression f init e in - ok @@ (init, Match_tuple ((names , e'), [])) - ) - | Match_variant (lst, _) -> ( + | Match_variant lst -> ( let aux init ((a , b) , e) = let%bind (init,e') = fold_map_expression f init e in ok (init, ((a , b) , e')) in let%bind (init,lst') = bind_fold_map_list aux init lst in - ok @@ (init, Match_variant (lst', ())) + ok @@ (init, Match_variant lst') ) diff --git a/src/passes/08-typer-new/todo_use_fold_generator.ml b/src/passes/08-typer-new/todo_use_fold_generator.ml index 22346cbf1..9580cc00c 100644 --- a/src/passes/08-typer-new/todo_use_fold_generator.ml +++ b/src/passes/08-typer-new/todo_use_fold_generator.ml @@ -3,6 +3,7 @@ module O = Ast_typed let convert_constructor' (I.Constructor c) = O.Constructor c let convert_label (I.Label c) = O.Label c + let convert_type_constant : I.type_constant -> O.type_constant = function | TC_unit -> TC_unit | TC_string -> TC_string diff --git a/src/passes/08-typer-new/typer.ml b/src/passes/08-typer-new/typer.ml index cd2c3ce12..59a2dff94 100644 --- a/src/passes/08-typer-new/typer.ml +++ b/src/passes/08-typer-new/typer.ml @@ -40,7 +40,7 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_option t in let%bind (match_none , state') = type_expression e state match_none in - let (opt, b, _) = match_some in + let (opt, b) = match_some in let e' = Environment.add_ez_binder opt tv e in let%bind (body , state'') = type_expression e' state' b in ok (O.Match_option {match_none ; match_some = { opt; body; tv}} , state'') @@ -49,23 +49,12 @@ and type_match : environment -> O'.typer_state -> O.type_expression -> I.matchin trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_list t in let%bind (match_nil , state') = type_expression e state match_nil in - let (hd, tl, b, _) = match_cons in + let (hd, tl, b) = match_cons in let e' = Environment.add_ez_binder hd t_elt e in let e' = Environment.add_ez_binder tl t e' in let%bind (body , state'') = type_expression e' state' b in ok (O.Match_list {match_nil ; match_cons = {hd; tl; body;tv=t}} , state'') - | Match_tuple ((vars, b),_) -> - let%bind tvs = - trace_strong (match_error ~expected:i ~actual:t loc) - @@ get_t_tuple t in - let%bind lst' = - generic_try (match_tuple_wrong_arity tvs vars loc) - @@ (fun () -> List.combine vars tvs) in - let aux prev (name, tv) = Environment.add_ez_binder name tv prev in - let e' = List.fold_left aux e lst' in - let%bind (body , state') = type_expression e' state b in - ok (O.Match_tuple {vars ; body ; tvs} , state') - | Match_variant (lst,_) -> + | Match_variant lst -> let%bind variant_opt = let aux acc ((constructor_name , _) , _) = let%bind (_ , variant) = @@ -362,7 +351,6 @@ and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression match cur with | Match_list { match_nil ; match_cons = { hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] | Match_option { match_none ; match_some = {opt=_; body; tv=_} } -> [ match_none ; body ] - | Match_tuple { vars=_ ; body ; tvs=_ } -> [ body ] | Match_variant { cases ; tv=_ } -> List.map (fun ({constructor=_; pattern=_; body} : O.matching_content_case) -> body) cases in List.map get_type_expression @@ aux m' in let%bind () = match tvs with diff --git a/src/passes/08-typer-new/untyper.ml b/src/passes/08-typer-new/untyper.ml index 91d554664..da478365d 100644 --- a/src/passes/08-typer-new/untyper.ml +++ b/src/passes/08-typer-new/untyper.ml @@ -264,8 +264,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result = return (e_record @@ LMap.of_list r') | E_record_accessor {record; path} -> let%bind r' = untype_expression record in - let Label s = path in - return (e_record_accessor r' s) + let Label path = path in + return (e_record_accessor r' (Label path)) | E_record_update {record; path; update} -> let%bind r' = untype_expression record in let%bind e = untype_expression update in @@ -299,22 +299,19 @@ and untype_lambda ty {binder; result} : I.lambda result = and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m -> let open I in match m with - | Match_tuple { vars ; body ; tvs=_ } -> - let%bind b = f body in - ok @@ I.Match_tuple ((vars, b),[]) | Match_option {match_none ; match_some = {opt; body;tv=_}} -> let%bind match_none = f match_none in let%bind some = f body in - let match_some = opt, some, () in + let match_some = opt, some in ok @@ Match_option {match_none ; match_some} | Match_list {match_nil ; match_cons = {hd;tl;body;tv=_}} -> let%bind match_nil = f match_nil in let%bind cons = f body in - let match_cons = hd , tl , cons, () in + let match_cons = hd , tl , cons in ok @@ Match_list {match_nil ; match_cons} | Match_variant { cases ; tv=_ } -> let aux ({constructor;pattern;body} : O.matching_content_case) = let%bind body = f body in ok ((unconvert_constructor' constructor,pattern),body) in let%bind lst' = bind_map_list aux cases in - ok @@ Match_variant (lst',()) + ok @@ Match_variant lst' diff --git a/src/passes/08-typer-old/typer.ml b/src/passes/08-typer-old/typer.ml index 1dc92eb28..f60c868ef 100644 --- a/src/passes/08-typer-old/typer.ml +++ b/src/passes/08-typer-old/typer.ml @@ -125,17 +125,6 @@ module Errors = struct ] in error ~data title message () - - let match_tuple_wrong_arity (expected:'a list) (actual:'b list) (loc:Location.t) () = - let title () = "matching tuple of different size" in - let message () = "" in - let data = [ - ("expected" , fun () -> Format.asprintf "%d" (List.length expected)) ; - ("actual" , fun () -> Format.asprintf "%d" (List.length actual)) ; - ("location" , fun () -> Format.asprintf "%a" Location.pp loc) - ] in - error ~data title message () - (* TODO: this should be a trace_info? *) let program_error (p:I.program) () = let message () = "" in @@ -528,7 +517,7 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_option t in let%bind match_none = f e match_none in - let (opt, b,_) = match_some in + let (opt, b) = match_some in let e' = Environment.add_ez_binder opt tv e in let%bind body = f e' b in ok (O.Match_option {match_none ; match_some = {opt; body; tv}}) @@ -537,23 +526,12 @@ and type_match : (environment -> I.expression -> O.expression result) -> environ trace_strong (match_error ~expected:i ~actual:t loc) @@ get_t_list t in let%bind match_nil = f e match_nil in - let (hd, tl, b,_) = match_cons in + let (hd, tl, b) = match_cons in let e' = Environment.add_ez_binder hd t_elt e in let e' = Environment.add_ez_binder tl t e' in let%bind body = f e' b in ok (O.Match_list {match_nil ; match_cons = {hd; tl; body; tv=t_elt}}) - | Match_tuple ((vars, b),_) -> - let%bind tvs = - trace_strong (match_error ~expected:i ~actual:t loc) - @@ get_t_tuple t in - let%bind vars' = - generic_try (match_tuple_wrong_arity tvs vars loc) - @@ (fun () -> List.combine vars tvs) in - let aux prev (name, tv) = Environment.add_ez_binder name tv prev in - let e' = List.fold_left aux e vars' in - let%bind body = f e' b in - ok (O.Match_tuple { vars ; body ; tvs}) - | Match_variant (lst,_) -> + | Match_variant lst -> let%bind variant_cases' = trace (match_error ~expected:i ~actual:t loc) @@ Ast_typed.Combinators.get_t_sum t in @@ -937,7 +915,6 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression match cur with | Match_list { match_nil ; match_cons = {hd=_ ; tl=_ ; body ; tv=_} } -> [ match_nil ; body ] | Match_option { match_none ; match_some = {opt=_ ; body ; tv=_ } } -> [ match_none ; body ] - | Match_tuple {vars=_;body;tvs=_} -> [ body ] | Match_variant {cases; tv=_} -> List.map (fun (c : O.matching_content_case) -> c.body) cases in List.map get_type_expression @@ aux m' in let aux prec cur = @@ -1081,7 +1058,7 @@ let rec untype_expression (e:O.expression) : (I.expression) result = | E_record_accessor {record; path} -> let%bind r' = untype_expression record in let Label s = path in - return (e_record_accessor r' s) + return (e_record_accessor r' (Label s)) | E_record_update {record=r; path=O.Label l; update=e} -> let%bind r' = untype_expression r in let%bind e = untype_expression e in @@ -1104,22 +1081,19 @@ let rec untype_expression (e:O.expression) : (I.expression) result = and untype_matching : (O.expression -> I.expression result) -> O.matching_expr -> I.matching_expr result = fun f m -> let open I in match m with - | Match_tuple {vars; body;tvs=_} -> - let%bind b = f body in - ok @@ I.Match_tuple ((vars, b),[]) | Match_option {match_none ; match_some = {opt; body ; tv=_}} -> let%bind match_none = f match_none in let%bind some = f body in - let match_some = opt, some, () in + let match_some = opt, some in ok @@ Match_option {match_none ; match_some} | Match_list {match_nil ; match_cons = {hd ; tl ; body ; tv=_}} -> let%bind match_nil = f match_nil in let%bind cons = f body in - let match_cons = hd , tl , cons, () in + let match_cons = hd , tl , cons in ok @@ Match_list {match_nil ; match_cons} | Match_variant {cases;tv=_} -> let aux ({constructor;pattern;body} : O.matching_content_case) = let%bind c' = f body in ok ((unconvert_constructor' constructor,pattern),c') in let%bind lst' = bind_map_list aux cases in - ok @@ Match_variant (lst',()) + ok @@ Match_variant lst' diff --git a/src/passes/09-self_ast_typed/helpers.ml b/src/passes/09-self_ast_typed/helpers.ml index a63a2893a..a22518a97 100644 --- a/src/passes/09-self_ast_typed/helpers.ml +++ b/src/passes/09-self_ast_typed/helpers.ml @@ -63,10 +63,6 @@ and fold_cases : 'a . 'a folder -> 'a -> matching_expr -> 'a result = fun f init let%bind res = fold_expression f res body in ok res ) - | Match_tuple {vars=_ ; body; tvs=_} -> ( - let%bind res = fold_expression f init body in - ok res - ) | Match_variant {cases;tv=_} -> ( let aux init' {constructor=_; pattern=_ ; body} = let%bind res' = fold_expression f init' body in @@ -140,10 +136,6 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> let%bind body = map_expression f body in ok @@ Match_option { match_none ; match_some = { opt ; body ; tv } } ) - | Match_tuple { vars ; body ; tvs } -> ( - let%bind body = map_expression f body in - ok @@ Match_tuple { vars ; body ; tvs } - ) | Match_variant {cases;tv} -> ( let aux { constructor ; pattern ; body } = let%bind body = map_expression f body in @@ -231,10 +223,6 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin let%bind (init, body) = fold_map_expression f init body in ok @@ (init, Match_option { match_none ; match_some = { opt ; body ; tv } }) ) - | Match_tuple { vars ; body ; tvs } -> ( - let%bind (init, body) = fold_map_expression f init body in - ok @@ (init, Match_tuple {vars ; body ; tvs }) - ) | Match_variant {cases ; tv} -> ( let aux init {constructor ; pattern ; body} = let%bind (init, body) = fold_map_expression f init body in diff --git a/src/passes/09-self_ast_typed/tail_recursion.ml b/src/passes/09-self_ast_typed/tail_recursion.ml index ef4098c36..ce9e3bd27 100644 --- a/src/passes/09-self_ast_typed/tail_recursion.ml +++ b/src/passes/09-self_ast_typed/tail_recursion.ml @@ -67,9 +67,6 @@ and check_recursive_call_in_matching = fun n final_path c -> let%bind _ = check_recursive_call n final_path match_none in let%bind _ = check_recursive_call n final_path body in ok () - | Match_tuple {vars=_;body;tvs=_} -> - let%bind _ = check_recursive_call n final_path body in - ok () | Match_variant {cases;tv=_} -> let aux {constructor=_; pattern=_; body} = let%bind _ = check_recursive_call n final_path body in diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 5ea4ea43f..6f643098b 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -32,16 +32,6 @@ them. please report this to the developers." in let content () = Format.asprintf "%a" Var.pp name in error title content - let row_loc l = ("location" , fun () -> Format.asprintf "%a" Location.pp l) - - let unsupported_pattern_matching kind location = - let title () = "unsupported pattern-matching" in - let content () = Format.asprintf "%s patterns aren't supported yet" kind in - let data = [ - row_loc location ; - ] in - error ~data title content - let not_functional_main location = let title () = "not functional main" in let content () = "main should be a function" in @@ -615,7 +605,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = trace_strong (corner_case ~loc:__LOC__ "building constructor") @@ aux expr' tree'' ) - | AST.Match_tuple _ -> fail @@ unsupported_pattern_matching "tuple" ae.location ) and transpile_lambda l (input_type , output_type) = @@ -739,7 +728,6 @@ and transpile_recursive {fun_name; fun_type; lambda} = trace_strong (corner_case ~loc:__LOC__ "building constructor") @@ aux expr tree'' ) - | AST.Match_tuple _ -> failwith "match_tuple not supported" in let%bind fun_type = transpile_type fun_type in let%bind (input_type,output_type) = get_t_function fun_type in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 986c200ba..03fa88165 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -184,27 +184,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex fun f ppf ((c,n),a) -> fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a -and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = +and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit = fun f ppf m -> match m with - | Match_tuple ((lst, b), _) -> - fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst - | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> + | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons - | Match_option {match_none ; match_some = (some, match_some, _)} -> + | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + | Match_tuple (lst, _,b) -> + fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b + | Match_record (lst, _,b) -> + fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b + | Match_variable (a, _,b) -> + fprintf ppf "%a -> %a" expression_variable a f b (* Shows the type expected for the matched value *) and matching_type ppf m = match m with - | Match_tuple _ -> - fprintf ppf "tuple" - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst | Match_list _ -> fprintf ppf "list" | Match_option _ -> fprintf ppf "option" + | Match_tuple _ -> + fprintf ppf "tuple" + | Match_record _ -> + fprintf ppf "record" + | Match_variable _ -> + fprintf ppf "variable" and matching_variant_case_type ppf ((c,n),_a) = fprintf ppf "| %a %a" constructor c expression_variable n diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index aaf589c9a..c30f5b433 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -148,9 +148,14 @@ let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit let ez_match_variant (lst : ((string * string) * 'a) list) = let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in - Match_variant (lst,()) + Match_variant lst let e_matching_variant ?loc a (lst : ((string * string)* 'a) list) = e_matching ?loc a (ez_match_variant lst) + +let e_matching_record ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_record (lst,ty_opt, expr) +let e_matching_tuple ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_tuple (lst,ty_opt, expr) +let e_matching_variable ?loc m var ty_opt expr = e_matching ?loc m @@ Match_variable (var,ty_opt, expr) + let e_record_ez ?loc (lst : (string * expr) list) : expression = let map = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in make_e ?loc @@ E_record map diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 0bb23e660..ac835c221 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -98,8 +98,11 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression -val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content +val ez_match_variant : ((string * string ) * expression) list -> matching_expr val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression +val e_matching_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> expression +val e_matching_tuple : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression +val e_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 877a7cf39..f932904d5 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -110,7 +110,20 @@ and record_update = {record: expression; path: label ; update: expression} -and matching_expr = (expr,unit) matching_content +and matching_expr = + | Match_variant of ((constructor' * expression_variable) * expression) list + | Match_list of { + match_nil : expression ; + match_cons : expression_variable * expression_variable * expression ; + } + | Match_option of { + match_none : expression ; + match_some : expression_variable * expression ; + } + | Match_tuple of expression_variable list * type_expression list option * expression + | Match_record of (label * expression_variable) list * type_expression list option * expression + | Match_variable of expression_variable * type_expression option * expression + and matching = { matchee: expression ; cases: matching_expr diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index cb48c7ec0..49b3404ea 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -150,27 +150,35 @@ and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * ex fun f ppf ((c,n),a) -> fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a -and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = +and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit = fun f ppf m -> match m with - | Match_tuple ((lst, b), _) -> - fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst - | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> + | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons - | Match_option {match_none ; match_some = (some, match_some, _)} -> + | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + | Match_tuple (lst, _,b) -> + fprintf ppf "(%a) -> %a" (list_sep_d expression_variable) lst f b + | Match_record (lst, _,b) -> + fprintf ppf "{%a} -> %a" (list_sep_d (fun ppf (a,b) -> fprintf ppf "%a = %a" label a expression_variable b)) lst f b + | Match_variable (a, _,b) -> + fprintf ppf "%a -> %a" expression_variable a f b (* Shows the type expected for the matched value *) and matching_type ppf m = match m with - | Match_tuple _ -> - fprintf ppf "tuple" - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst | Match_list _ -> fprintf ppf "list" | Match_option _ -> fprintf ppf "option" + | Match_tuple _ -> + fprintf ppf "tuple" + | Match_record _ -> + fprintf ppf "record" + | Match_variable _ -> + fprintf ppf "variable" and matching_variant_case_type ppf ((c,n),_a) = fprintf ppf "| %a %a" constructor c expression_variable n diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index bdf2f660b..f62904220 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -106,7 +106,20 @@ and constructor = {constructor: constructor'; element: expression} and record_accessor = {record: expression; path: label} and record_update = {record: expression; path: label ; update: expression} -and matching_expr = (expr,unit) matching_content +and matching_expr = + | Match_variant of ((constructor' * expression_variable) * expression) list + | Match_list of { + match_nil : expression ; + match_cons : expression_variable * expression_variable * expression ; + } + | Match_option of { + match_none : expression ; + match_some : expression_variable * expression ; + } + | Match_tuple of expression_variable list * type_expression list option * expression + | Match_record of (label * expression_variable) list * type_expression list option * expression + | Match_variable of expression_variable * type_expression option * expression + and matching = { matchee: expression ; cases: matching_expr diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index cd269dcd6..465107275 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -66,26 +66,22 @@ and assoc_expression ppf : expr * expr -> unit = and single_record_patch ppf ((p, expr) : label * expr) = fprintf ppf "%a <- %a" label p expression expr -and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = +and matching_variant_case : (_ -> expression -> unit) -> _ -> (constructor' * expression_variable) * expression -> unit = fun f ppf ((c,n),a) -> fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a -and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = +and matching : (formatter -> expression -> unit) -> formatter -> matching_expr -> unit = fun f ppf m -> match m with - | Match_tuple ((lst, b), _) -> - fprintf ppf "@[| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "@[%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst - | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> + | Match_list {match_nil ; match_cons = (hd, tl, match_cons)} -> fprintf ppf "@[| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons - | Match_option {match_none ; match_some = (some, match_some, _)} -> + | Match_option {match_none ; match_some = (some, match_some)} -> fprintf ppf "@[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some (* Shows the type expected for the matched value *) and matching_type ppf m = match m with - | Match_tuple _ -> - fprintf ppf "tuple" - | Match_variant (lst, _) -> + | Match_variant lst -> fprintf ppf "variant %a" (list_sep matching_variant_case_type (tag "@.")) lst | Match_list _ -> fprintf ppf "list" diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index cb24f203d..5b6cca73c 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -107,7 +107,7 @@ let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constru let e_matching ?loc a b : expression = make_e ?loc @@ E_matching {matchee=a;cases=b} let e_record ?loc map = make_e ?loc @@ E_record map -let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = Label b} +let e_record_accessor ?loc a b = make_e ?loc @@ E_record_accessor {record = a; path = b} let e_record_update ?loc record path update = make_e ?loc @@ E_record_update {record; path; update} let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; type_annotation = ty} diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 550f87883..10d8f6459 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -74,7 +74,7 @@ val e_string_cat : ?loc:Location.t -> expression -> expression -> expression val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression -val e_record_accessor : ?loc:Location.t -> expression -> string -> expression +val e_record_accessor : ?loc:Location.t -> expression -> label -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index 2a76591df..ca9a97a8f 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -76,7 +76,17 @@ and constructor = {constructor: constructor'; element: expression} and record_accessor = {record: expression; path: label} and record_update = {record: expression; path: label ; update: expression} -and matching_expr = (expr,unit) matching_content +and matching_expr = + | Match_list of { + match_nil : expression ; + match_cons : expression_variable * expression_variable * expression ; + } + | Match_option of { + match_none : expression ; + match_some : expression_variable * expression ; + } + | Match_variant of ((constructor' * expression_variable) * expression) list + and matching = { matchee: expression ; cases: matching_expr diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 08e2f778c..98a18bf07 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -315,8 +315,6 @@ and matching_variant_case : (_ -> expression -> unit) -> _ -> matching_content_c fprintf ppf "| %a %a -> %a" constructor c expression_variable pattern f body and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = fun f ppf m -> match m with - | Match_tuple {vars; body; tvs=_} -> - fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) vars f body | Match_variant {cases ; tv=_} -> fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) cases | Match_list {match_nil ; match_cons = {hd; tl; body; tv=_}} -> diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index 84a939ba4..6534fc5d5 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -124,12 +124,6 @@ and matching_content_option = { and expression_variable_list = expression_variable list and type_expression_list = type_expression list -and matching_content_tuple = { - vars : expression_variable_list ; - body : expression ; - tvs : type_expression_list ; - } - and matching_content_case = { constructor : constructor' ; pattern : expression_variable ; @@ -146,7 +140,6 @@ and matching_content_variant = { and matching_expr = | Match_list of matching_content_list | Match_option of matching_content_option - | Match_tuple of matching_content_tuple | Match_variant of matching_content_variant and constant' = diff --git a/src/stages/4-ast_typed/compute_environment.ml b/src/stages/4-ast_typed/compute_environment.ml index ce4013a28..cde26d1d1 100644 --- a/src/stages/4-ast_typed/compute_environment.ml +++ b/src/stages/4-ast_typed/compute_environment.ml @@ -92,21 +92,6 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs -> in return @@ Match_option { match_none ; match_some } ) - | Match_tuple c -> ( - let var_tvs = - try ( - List.combine c.vars c.tvs - ) with _ -> raise (Failure ("Internal error: broken invariant at " ^ __LOC__)) - in - let env' = - let aux prev (var , tv) = - Environment.add_ez_binder var tv prev - in - List.fold_left aux env var_tvs - in - let body = self ~env' c.body in - return @@ Match_tuple { c with body } - ) | Match_variant c -> ( let variant_type = Combinators.get_t_sum_exn c.tv in let cases = diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 537a734f3..ae8136654 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -236,8 +236,6 @@ module Free_variables = struct match m with | Match_list { match_nil = n ; match_cons = {hd; tl; body; tv=_} } -> union (f b n) (f (union (of_list [hd ; tl]) b) body) | Match_option { match_none = n ; match_some = {opt; body; tv=_} } -> union (f b n) (f (union (singleton opt) b) body) - | Match_tuple { vars ; body ; tvs=_ } -> - f (union (of_list vars) b) body | Match_variant { cases ; tv=_ } -> unions @@ List.map (matching_variant_case f b) cases and matching_expression = fun x -> matching expression x diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index d62665149..20e0fec3a 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -90,8 +90,6 @@ module Captured_variables = struct let%bind n' = f b n in let%bind s' = f (union (singleton opt) b) body in ok @@ union n' s' - | Match_tuple { vars ; body ; tvs=_ } -> - f (union (of_list vars) b) body | Match_variant { cases ; tv=_ } -> let%bind lst' = bind_map_list (matching_variant_case f b) cases in ok @@ unions lst' diff --git a/src/stages/common/ast_common.ml b/src/stages/common/ast_common.ml index eefa2903c..605fd90c8 100644 --- a/src/stages/common/ast_common.ml +++ b/src/stages/common/ast_common.ml @@ -1,3 +1,5 @@ +include Types + module Types = Types module PP = PP module Helpers = Helpers diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 01b657289..cf9ad3817 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -11,6 +11,7 @@ type label = Label of string module CMap = Map.Make( struct type t = constructor' let compare (Constructor a) (Constructor b) = compare a b end) module LMap = Map.Make( struct type t = label let compare (Label a) (Label b) = String.compare a b end) + type 'a label_map = 'a LMap.t type 'a constructor_map = 'a CMap.t @@ -169,18 +170,6 @@ type literal = | Literal_void | Literal_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation -and ('a,'tv) matching_content = - | Match_list of { - match_nil : 'a ; - match_cons : expression_variable * expression_variable * 'a * 'tv; - } - | Match_option of { - match_none : 'a ; - match_some : expression_variable * 'a * 'tv; - } - | Match_tuple of (expression_variable list * 'a) * 'tv list - | Match_variant of ((constructor' * expression_variable) * 'a) list * 'tv - and constant' = | C_INT | C_UNIT