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

Add new matching cases and fix compilation of match_tuples

Browse Source
This commit is contained in:
Pierre-Emmanuel Wulfman 2020-06-04 15:30:14 +02:00
parent 5cfe6e893c
commit 5896b2a63a
31 changed files with 369 additions and 337 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
src/passes/02-concrete_to_imperative/cameligo.ml
View File

@ -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 ())

6
src/passes/02-concrete_to_imperative/pascaligo.ml
View File

@ -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") @@

120
src/passes/03-self_ast_imperative/helpers.ml
View File

@ -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'))
)

62
src/passes/04-imperative_to_sugar/imperative_to_sugar.ml
View File

@ -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)

120
src/passes/05-self_ast_sugar/helpers.ml
View File

@ -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'))
)

76
src/passes/06-sugar_to_core/sugar_to_core.ml
View File

@ -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

42
src/passes/07-self_ast_core/helpers.ml
View File

@ -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')
)

1
src/passes/08-typer-new/todo_use_fold_generator.ml
View File

@ -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

18
src/passes/08-typer-new/typer.ml
View File

@ -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

13
src/passes/08-typer-new/untyper.ml
View File

@ -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'

40
src/passes/08-typer-old/typer.ml
View File

@ -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'

12
src/passes/09-self_ast_typed/helpers.ml
View File

@ -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

3
src/passes/09-self_ast_typed/tail_recursion.ml
View File

@ -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

12
src/passes/10-transpiler/transpiler.ml
View File

@ -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

26
src/stages/1-ast_imperative/PP.ml
View File

@ -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

7
src/stages/1-ast_imperative/combinators.ml
View File

@ -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

5
src/stages/1-ast_imperative/combinators.mli
View File

@ -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

15
src/stages/1-ast_imperative/types.ml
View File

@ -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

26
src/stages/2-ast_sugar/PP.ml
View File

@ -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

15
src/stages/2-ast_sugar/types.ml
View File

@ -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

16
src/stages/3-ast_core/PP.ml
View File

@ -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 "@[<hv>| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b
| Match_variant (lst, _) ->
| Match_variant lst ->
fprintf ppf "@[<hv>%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 "@[<hv>| 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 "@[<hv>| 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"

2
src/stages/3-ast_core/combinators.ml
View File

@ -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}

2
src/stages/3-ast_core/combinators.mli
View File

@ -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

12
src/stages/3-ast_core/types.ml
View File

@ -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

2
src/stages/4-ast_typed/PP.ml
View File

@ -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=_}} ->

7
src/stages/4-ast_typed/ast.ml
View File

@ -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' =

15
src/stages/4-ast_typed/compute_environment.ml
View File

@ -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 =

2
src/stages/4-ast_typed/misc.ml
View File

@ -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

2
src/stages/4-ast_typed/misc_smart.ml
View File

@ -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'

2
src/stages/common/ast_common.ml
View File

@ -1,3 +1,5 @@
include Types
module Types = Types
module PP = PP
module Helpers = Helpers

13
src/stages/common/types.ml
View File

@ -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