add assign back
This commit is contained in:
parent
63793ddc76
commit
21e8298a4e
@ -316,8 +316,8 @@ and eval : Ast_typed.expression -> env -> value result
|
|||||||
ok (label,v'))
|
ok (label,v'))
|
||||||
(LMap.to_kv_list recmap) in
|
(LMap.to_kv_list recmap) in
|
||||||
ok @@ V_Record (LMap.of_list lv')
|
ok @@ V_Record (LMap.of_list lv')
|
||||||
| E_record_accessor { expr ; label} -> (
|
| E_record_accessor { record ; label} -> (
|
||||||
let%bind record' = eval expr env in
|
let%bind record' = eval record env in
|
||||||
match record' with
|
match record' with
|
||||||
| V_Record recmap ->
|
| V_Record recmap ->
|
||||||
let%bind a = trace_option (simple_error "unknown record field") @@
|
let%bind a = trace_option (simple_error "unknown record field") @@
|
||||||
|
@ -301,11 +301,12 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
trace_strong (corner_case ~loc:__LOC__ "record build") @@
|
trace_strong (corner_case ~loc:__LOC__ "record build") @@
|
||||||
Append_tree.fold_ne (transpile_annotated_expression) aux node
|
Append_tree.fold_ne (transpile_annotated_expression) aux node
|
||||||
)
|
)
|
||||||
| E_record_accessor {expr; label} ->
|
| E_record_accessor {record; label} ->
|
||||||
let%bind ty' = transpile_type (get_type_expression expr) in
|
let ty = get_type_expression record in
|
||||||
|
let%bind ty' = transpile_type ty in
|
||||||
let%bind ty_lmap =
|
let%bind ty_lmap =
|
||||||
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
|
trace_strong (corner_case ~loc:__LOC__ "not a record") @@
|
||||||
get_t_record (get_type_expression expr) in
|
get_t_record ty in
|
||||||
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
|
let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in
|
||||||
let%bind path =
|
let%bind path =
|
||||||
trace_strong (corner_case ~loc:__LOC__ "record access") @@
|
trace_strong (corner_case ~loc:__LOC__ "record access") @@
|
||||||
@ -315,7 +316,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
|
|||||||
| `Left -> C_CAR
|
| `Left -> C_CAR
|
||||||
| `Right -> C_CDR in
|
| `Right -> C_CDR in
|
||||||
Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in
|
Combinators.Expression.make_tpl (E_constant {cons_name=c;arguments=[pred]} , ty) in
|
||||||
let%bind record' = transpile_annotated_expression expr in
|
let%bind record' = transpile_annotated_expression record in
|
||||||
let expr = List.fold_left aux record' path in
|
let expr = List.fold_left aux record' path in
|
||||||
ok expr
|
ok expr
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
|
@ -383,11 +383,10 @@ let rec compile_expression :
|
|||||||
match variables with
|
match variables with
|
||||||
| hd :: [] ->
|
| hd :: [] ->
|
||||||
if (List.length prep_vars = 1)
|
if (List.length prep_vars = 1)
|
||||||
then e_let_in hd false inline rhs_b_expr body
|
then e_let_in hd inline rhs_b_expr body
|
||||||
else e_let_in hd false inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
|
else e_let_in hd inline (e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - 1))) body
|
||||||
| hd :: tl ->
|
| hd :: tl ->
|
||||||
e_let_in hd
|
e_let_in hd
|
||||||
false
|
|
||||||
inline
|
inline
|
||||||
(e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
|
(e_accessor rhs_b_expr (string_of_int ((List.length prep_vars) - (List.length tl) - 1)))
|
||||||
(chain_let_in tl body)
|
(chain_let_in tl body)
|
||||||
@ -408,7 +407,7 @@ let rec compile_expression :
|
|||||||
let%bind ret_expr = if List.length prep_vars = 1
|
let%bind ret_expr = if List.length prep_vars = 1
|
||||||
then ok (chain_let_in prep_vars body)
|
then ok (chain_let_in prep_vars body)
|
||||||
(* Bind the right hand side so we only evaluate it once *)
|
(* Bind the right hand side so we only evaluate it once *)
|
||||||
else ok (e_let_in (rhs_b, ty_opt) false inline rhs' (chain_let_in prep_vars body))
|
else ok (e_let_in (rhs_b, ty_opt) inline rhs' (chain_let_in prep_vars body))
|
||||||
in
|
in
|
||||||
let%bind ret_expr = match kwd_rec with
|
let%bind ret_expr = match kwd_rec with
|
||||||
| None -> ok @@ ret_expr
|
| None -> ok @@ ret_expr
|
||||||
@ -572,7 +571,7 @@ let rec compile_expression :
|
|||||||
| Raw.PVar y ->
|
| Raw.PVar y ->
|
||||||
let var_name = Var.of_name y.value in
|
let var_name = Var.of_name y.value in
|
||||||
let%bind type_expr = compile_type_expression x'.type_expr in
|
let%bind type_expr = compile_type_expression x'.type_expr in
|
||||||
return @@ e_let_in (var_name , Some type_expr) false false e rhs
|
return @@ e_let_in (var_name , Some type_expr) false e rhs
|
||||||
| _ -> default_action ()
|
| _ -> default_action ()
|
||||||
)
|
)
|
||||||
| _ -> default_action ()
|
| _ -> default_action ()
|
||||||
|
@ -14,8 +14,6 @@ let pseq_to_list = function
|
|||||||
| Some lst -> npseq_to_list lst
|
| Some lst -> npseq_to_list lst
|
||||||
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
|
let get_value : 'a Raw.reg -> 'a = fun x -> x.value
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
module Errors = struct
|
module Errors = struct
|
||||||
let unsupported_cst_constr p =
|
let unsupported_cst_constr p =
|
||||||
let title () = "" in
|
let title () = "" in
|
||||||
@ -134,10 +132,10 @@ let r_split = Location.r_split
|
|||||||
[return_statement] is used for non-let-in statements.
|
[return_statement] is used for non-let-in statements.
|
||||||
*)
|
*)
|
||||||
|
|
||||||
let return_let_in ?loc binder mut inline rhs = ok @@ fun expr'_opt ->
|
let return_let_in ?loc binder inline rhs = ok @@ fun expr'_opt ->
|
||||||
match expr'_opt with
|
match expr'_opt with
|
||||||
| None -> ok @@ e_let_in ?loc binder mut inline rhs (e_skip ())
|
| None -> ok @@ e_let_in ?loc binder inline rhs (e_skip ())
|
||||||
| Some expr' -> ok @@ e_let_in ?loc binder mut inline rhs expr'
|
| Some expr' -> ok @@ e_let_in ?loc binder inline rhs expr'
|
||||||
|
|
||||||
let return_statement expr = ok @@ fun expr'_opt ->
|
let return_statement expr = ok @@ fun expr'_opt ->
|
||||||
match expr'_opt with
|
match expr'_opt with
|
||||||
@ -525,7 +523,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
|
|||||||
let name = x.name.value in
|
let name = x.name.value in
|
||||||
let%bind t = compile_type_expression x.var_type in
|
let%bind t = compile_type_expression x.var_type in
|
||||||
let%bind expression = compile_expression x.init in
|
let%bind expression = compile_expression x.init in
|
||||||
return_let_in ~loc (Var.of_name name, Some t) false false expression
|
return_let_in ~loc (Var.of_name name, Some t) false expression
|
||||||
| LocalConst x ->
|
| LocalConst x ->
|
||||||
let (x , loc) = r_split x in
|
let (x , loc) = r_split x in
|
||||||
let name = x.name.value in
|
let name = x.name.value in
|
||||||
@ -537,7 +535,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
|
|||||||
| Some {value; _} ->
|
| Some {value; _} ->
|
||||||
npseq_to_list value.ne_elements
|
npseq_to_list value.ne_elements
|
||||||
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
|
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
|
||||||
in return_let_in ~loc (Var.of_name name, Some t) false inline expression
|
in return_let_in ~loc (Var.of_name name, Some t) inline expression
|
||||||
| LocalFun f ->
|
| LocalFun f ->
|
||||||
let (f , loc) = r_split f in
|
let (f , loc) = r_split f in
|
||||||
let%bind (binder, expr) = compile_fun_decl ~loc f in
|
let%bind (binder, expr) = compile_fun_decl ~loc f in
|
||||||
@ -547,7 +545,7 @@ and compile_data_declaration : Raw.data_decl -> _ result =
|
|||||||
| Some {value; _} ->
|
| Some {value; _} ->
|
||||||
npseq_to_list value.ne_elements
|
npseq_to_list value.ne_elements
|
||||||
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
|
|> List.exists (fun Region.{value; _} -> value = "\"inline\"")
|
||||||
in return_let_in ~loc binder false inline expr
|
in return_let_in ~loc binder inline expr
|
||||||
|
|
||||||
and compile_param :
|
and compile_param :
|
||||||
Raw.param_decl -> (string * type_expression) result =
|
Raw.param_decl -> (string * type_expression) result =
|
||||||
@ -618,7 +616,7 @@ and compile_fun_decl :
|
|||||||
let expr =
|
let expr =
|
||||||
e_accessor (e_variable arguments_name) (string_of_int i) in
|
e_accessor (e_variable arguments_name) (string_of_int i) in
|
||||||
let type_variable = Some type_expr in
|
let type_variable = Some type_expr in
|
||||||
let ass = return_let_in (Var.of_name param , type_variable) false inline expr in
|
let ass = return_let_in (Var.of_name param , type_variable) inline expr in
|
||||||
ass
|
ass
|
||||||
in
|
in
|
||||||
bind_list @@ List.mapi aux params in
|
bind_list @@ List.mapi aux params in
|
||||||
@ -681,7 +679,7 @@ and compile_fun_expression :
|
|||||||
let aux = fun i (param, param_type) ->
|
let aux = fun i (param, param_type) ->
|
||||||
let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
|
let expr = e_accessor (e_variable arguments_name) (string_of_int i) in
|
||||||
let type_variable = Some param_type in
|
let type_variable = Some param_type in
|
||||||
let ass = return_let_in (Var.of_name param , type_variable) false false expr in
|
let ass = return_let_in (Var.of_name param , type_variable) false expr in
|
||||||
ass
|
ass
|
||||||
in
|
in
|
||||||
bind_list @@ List.mapi aux params in
|
bind_list @@ List.mapi aux params in
|
||||||
@ -817,8 +815,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
match a.lhs with
|
match a.lhs with
|
||||||
| Path path -> (
|
| Path path -> (
|
||||||
let (name , path') = compile_path path in
|
let (name , path') = compile_path path in
|
||||||
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc name path' value_expr in
|
return_statement @@ e_ez_assign ~loc name path' value_expr
|
||||||
return_let_in let_binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
| MapPath v -> (
|
| MapPath v -> (
|
||||||
let v' = v.value in
|
let v' = v.value in
|
||||||
@ -831,8 +828,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
in
|
in
|
||||||
let%bind key_expr = compile_expression v'.index.value.inside in
|
let%bind key_expr = compile_expression v'.index.value.inside in
|
||||||
let expr' = e_map_add key_expr value_expr map in
|
let expr' = e_map_add key_expr value_expr map in
|
||||||
let (let_binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr' in
|
return_statement @@ e_ez_assign ~loc varname path expr'
|
||||||
return_let_in let_binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
| CaseInstr c -> (
|
| CaseInstr c -> (
|
||||||
@ -872,9 +868,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
|
let u : Raw.update = {record=r.path;kwd_with=r.kwd_with; updates=update} in
|
||||||
let%bind expr = compile_update {value=u;region=reg} in
|
let%bind expr = compile_update {value=u;region=reg} in
|
||||||
let (name , access_path) = compile_path r.path in
|
let (name , access_path) = compile_path r.path in
|
||||||
let loc = Some loc in
|
return_statement @@ e_ez_assign ~loc name access_path expr
|
||||||
let (binder, mut, rhs, inline) = e_assign_with_let ?loc name access_path expr in
|
|
||||||
return_let_in binder mut inline rhs
|
|
||||||
|
|
||||||
)
|
)
|
||||||
| MapPatch patch -> (
|
| MapPatch patch -> (
|
||||||
@ -897,8 +891,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
inj
|
inj
|
||||||
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
|
(e_accessor_list ~loc (e_variable (Var.of_name name)) access_path)
|
||||||
in
|
in
|
||||||
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
|
return_statement @@ e_ez_assign ~loc name access_path assigns
|
||||||
return_let_in binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
| SetPatch patch -> (
|
| SetPatch patch -> (
|
||||||
let (setp, loc) = r_split patch in
|
let (setp, loc) = r_split patch in
|
||||||
@ -913,8 +906,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
let assigns = List.fold_right
|
let assigns = List.fold_right
|
||||||
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
(fun hd s -> e_constant C_SET_ADD [hd ; s])
|
||||||
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
|
inj (e_accessor_list ~loc (e_variable (Var.of_name name)) access_path) in
|
||||||
let (binder, mut, rhs, inline) = e_assign_with_let ~loc name access_path assigns in
|
return_statement @@ e_ez_assign ~loc name access_path assigns
|
||||||
return_let_in binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
| MapRemove r -> (
|
| MapRemove r -> (
|
||||||
let (v , loc) = r_split r in
|
let (v , loc) = r_split r in
|
||||||
@ -928,8 +920,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
in
|
in
|
||||||
let%bind key' = compile_expression key in
|
let%bind key' = compile_expression key in
|
||||||
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
let expr = e_constant ~loc C_MAP_REMOVE [key' ; map] in
|
||||||
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
|
return_statement @@ e_ez_assign ~loc varname path expr
|
||||||
return_let_in binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
| SetRemove r -> (
|
| SetRemove r -> (
|
||||||
let (set_rm, loc) = r_split r in
|
let (set_rm, loc) = r_split r in
|
||||||
@ -942,8 +933,7 @@ and compile_single_instruction : Raw.instruction -> (_ -> expression result) res
|
|||||||
in
|
in
|
||||||
let%bind removed' = compile_expression set_rm.element in
|
let%bind removed' = compile_expression set_rm.element in
|
||||||
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
|
let expr = e_constant ~loc C_SET_REMOVE [removed' ; set] in
|
||||||
let (binder, mut, rhs, inline) = e_assign_with_let ~loc varname path expr in
|
return_statement @@ e_ez_assign ~loc varname path expr
|
||||||
return_let_in binder mut inline rhs
|
|
||||||
)
|
)
|
||||||
|
|
||||||
and compile_path : Raw.path -> string * string list = fun p ->
|
and compile_path : Raw.path -> string * string list = fun p ->
|
||||||
|
@ -47,8 +47,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = fold_expression self res update in
|
let%bind res = fold_expression self res update in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_accessor {expr} -> (
|
| E_record_accessor {record} -> (
|
||||||
let%bind res = self init' expr in
|
let%bind res = self init' record in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
@ -63,6 +63,9 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let ab = (expr1,expr2) in
|
let ab = (expr1,expr2) in
|
||||||
let%bind res = bind_fold_pair self init' ab in
|
let%bind res = bind_fold_pair self init' ab in
|
||||||
ok res
|
ok res
|
||||||
|
| E_assign {variable=_;access_path=_;expression} ->
|
||||||
|
let%bind res = self init' expression in
|
||||||
|
ok res
|
||||||
| E_for {body; _} ->
|
| E_for {body; _} ->
|
||||||
let%bind res = self init' body in
|
let%bind res = self init' body in
|
||||||
ok res
|
ok res
|
||||||
@ -76,6 +79,7 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
ok res
|
ok res
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
|
||||||
match m with
|
match m with
|
||||||
| Match_bool { match_true ; match_false } -> (
|
| Match_bool { match_true ; match_false } -> (
|
||||||
@ -145,8 +149,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
return @@ E_matching {matchee=e';cases=cases'}
|
return @@ E_matching {matchee=e';cases=cases'}
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind e' = self acc.expr in
|
let%bind e' = self acc.record in
|
||||||
return @@ E_record_accessor {acc with expr = e'}
|
return @@ E_record_accessor {acc with record = e'}
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
@ -166,10 +170,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind (lamb,args) = bind_map_pair self ab in
|
let%bind (lamb,args) = bind_map_pair self ab in
|
||||||
return @@ E_application {lamb;args}
|
return @@ E_application {lamb;args}
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
|
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
|
||||||
let%bind rhs = self rhs in
|
let%bind rhs = self rhs in
|
||||||
let%bind let_result = self let_result in
|
let%bind let_result = self let_result in
|
||||||
return @@ E_let_in { let_binder ; mut; rhs ; let_result; inline }
|
return @@ E_let_in { let_binder ; rhs ; let_result; inline }
|
||||||
)
|
)
|
||||||
| E_lambda { binder ; input_type ; output_type ; result } -> (
|
| E_lambda { binder ; input_type ; output_type ; result } -> (
|
||||||
let%bind result = self result in
|
let%bind result = self result in
|
||||||
@ -187,6 +191,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
|
let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in
|
||||||
return @@ E_sequence {expr1;expr2}
|
return @@ E_sequence {expr1;expr2}
|
||||||
)
|
)
|
||||||
|
| E_assign {variable;access_path;expression} -> (
|
||||||
|
let%bind expression = self expression in
|
||||||
|
return @@ E_assign {variable;access_path;expression}
|
||||||
|
)
|
||||||
| E_for {binder; start; final; increment; body} ->
|
| E_for {binder; start; final; increment; body} ->
|
||||||
let%bind body = self body in
|
let%bind body = self body in
|
||||||
return @@ E_for {binder; start; final; increment; body}
|
return @@ E_for {binder; start; final; increment; body}
|
||||||
@ -303,8 +311,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind (res, e') = self init' acc.expr in
|
let%bind (res, e') = self init' acc.record in
|
||||||
ok (res, return @@ E_record_accessor {acc with expr = e'})
|
ok (res, return @@ E_record_accessor {acc with record = e'})
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||||
@ -325,10 +333,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
|
let%bind (res,(a,b)) = bind_fold_map_pair self init' ab in
|
||||||
ok (res, return @@ E_application {lamb=a;args=b})
|
ok (res, return @@ E_application {lamb=a;args=b})
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder ; mut; rhs ; let_result; inline } -> (
|
| E_let_in { let_binder ; rhs ; let_result; inline } -> (
|
||||||
let%bind (res,rhs) = self init' rhs in
|
let%bind (res,rhs) = self init' rhs in
|
||||||
let%bind (res,let_result) = self res let_result in
|
let%bind (res,let_result) = self res let_result in
|
||||||
ok (res, return @@ E_let_in { let_binder ; mut; rhs ; let_result ; inline })
|
ok (res, return @@ E_let_in { let_binder ; rhs ; let_result ; inline })
|
||||||
)
|
)
|
||||||
| E_lambda { binder ; input_type ; output_type ; result } -> (
|
| E_lambda { binder ; input_type ; output_type ; result } -> (
|
||||||
let%bind (res,result) = self init' result in
|
let%bind (res,result) = self init' result in
|
||||||
@ -346,6 +354,9 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
|
let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in
|
||||||
ok (res, return @@ E_sequence {expr1;expr2})
|
ok (res, return @@ E_sequence {expr1;expr2})
|
||||||
)
|
)
|
||||||
|
| E_assign {variable;access_path;expression} ->
|
||||||
|
let%bind (res, expression) = self init' expression in
|
||||||
|
ok (res, return @@ E_assign {variable;access_path;expression})
|
||||||
| E_for {binder; start; final; increment; body} ->
|
| E_for {binder; start; final; increment; body} ->
|
||||||
let%bind (res, body) = self init' body in
|
let%bind (res, body) = self init' body in
|
||||||
ok (res, return @@ E_for {binder; start; final; increment; body})
|
ok (res, return @@ E_for {binder; start; final; increment; body})
|
||||||
|
@ -37,7 +37,7 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
|
|||||||
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result)
|
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs let_result)
|
||||||
else(
|
else(
|
||||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
||||||
let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) (Var.to_name name) (O.e_variable name)) let_result in
|
let expr = O.e_let_in (env,None) false false (O.e_record_update (O.e_variable env) (Var.to_name name) (O.e_variable name)) let_result in
|
||||||
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
||||||
)
|
)
|
||||||
| E_constant {cons_name=C_MAP_FOLD;arguments= _}
|
| E_constant {cons_name=C_MAP_FOLD;arguments= _}
|
||||||
@ -70,8 +70,8 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
|
|||||||
else(
|
else(
|
||||||
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
let free_var = if (List.mem name free_var) then free_var else name::free_var in
|
||||||
let expr = O.e_let_in (env,None) false false (
|
let expr = O.e_let_in (env,None) false false (
|
||||||
O.e_update (O.e_variable env) ("0")
|
O.e_record_update (O.e_variable env) ("0")
|
||||||
(O.e_update (O.e_accessor (O.e_variable env) "0") (Var.to_name name) (O.e_variable name))
|
(O.e_record_update (O.e_record_accessor (O.e_variable env) "0") (Var.to_name name) (O.e_variable name))
|
||||||
)
|
)
|
||||||
let_result in
|
let_result in
|
||||||
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
ok (true,(decl_var, free_var), O.e_let_in let_binder false false rhs expr)
|
||||||
@ -95,7 +95,7 @@ and store_mutable_variable (free_vars : I.expression_variable list) =
|
|||||||
|
|
||||||
and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) =
|
and restore_mutable_variable (expr : O.expression->O.expression_content) (free_vars : O.expression_variable list) (env : O.expression_variable) =
|
||||||
let aux (f: O.expression -> O.expression) (ev: O.expression_variable) =
|
let aux (f: O.expression -> O.expression) (ev: O.expression_variable) =
|
||||||
fun expr -> f (O.e_let_in (ev,None) true false (O.e_accessor (O.e_variable env) (Var.to_name ev)) expr)
|
fun expr -> f (O.e_let_in (ev,None) true false (O.e_record_accessor (O.e_variable env) (Var.to_name ev)) expr)
|
||||||
in
|
in
|
||||||
let ef = List.fold_left aux (fun e -> e) free_vars in
|
let ef = List.fold_left aux (fun e -> e) free_vars in
|
||||||
expr (ef (O.e_skip ()))
|
expr (ef (O.e_skip ()))
|
||||||
@ -178,12 +178,12 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind fun_type = compile_type_expression fun_type in
|
let%bind fun_type = compile_type_expression fun_type in
|
||||||
let%bind lambda = compile_lambda lambda in
|
let%bind lambda = compile_lambda lambda in
|
||||||
return @@ O.E_recursive {fun_name;fun_type;lambda}
|
return @@ O.E_recursive {fun_name;fun_type;lambda}
|
||||||
| I.E_let_in {let_binder;mut;inline;rhs;let_result} ->
|
| I.E_let_in {let_binder;inline;rhs;let_result} ->
|
||||||
let (binder,ty_opt) = let_binder in
|
let (binder,ty_opt) = let_binder in
|
||||||
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
|
let%bind ty_opt = bind_map_option compile_type_expression ty_opt in
|
||||||
let%bind rhs = compile_expression rhs in
|
let%bind rhs = compile_expression rhs in
|
||||||
let%bind let_result = compile_expression let_result in
|
let%bind let_result = compile_expression let_result in
|
||||||
return @@ O.E_let_in {let_binder=(binder,ty_opt);mut;inline;rhs;let_result}
|
return @@ O.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
|
||||||
| I.E_constructor {constructor;element} ->
|
| I.E_constructor {constructor;element} ->
|
||||||
let%bind element = compile_expression element in
|
let%bind element = compile_expression element in
|
||||||
return @@ O.E_constructor {constructor;element}
|
return @@ O.E_constructor {constructor;element}
|
||||||
@ -199,9 +199,9 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.E_record (O.LMap.of_list record)
|
return @@ O.E_record (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {expr;label} ->
|
| I.E_record_accessor {record;label} ->
|
||||||
let%bind expr = compile_expression expr in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.E_record_accessor {expr;label}
|
return @@ O.E_record_accessor {record;label}
|
||||||
| I.E_record_update {record;path;update} ->
|
| I.E_record_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
@ -231,11 +231,18 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind anno_expr = compile_expression anno_expr in
|
let%bind anno_expr = compile_expression anno_expr in
|
||||||
let%bind type_annotation = compile_type_expression type_annotation in
|
let%bind type_annotation = compile_type_expression type_annotation in
|
||||||
return @@ O.E_ascription {anno_expr; type_annotation}
|
return @@ O.E_ascription {anno_expr; type_annotation}
|
||||||
|
| I.E_sequence {expr1={expression_content=I.E_assign expr1;_}; expr2} ->
|
||||||
|
let%bind expr2 = compile_expression expr2 in
|
||||||
|
let%bind ret = compile_assign expr1 @@ expr2 in
|
||||||
|
return @@ ret
|
||||||
| I.E_sequence {expr1; expr2} ->
|
| I.E_sequence {expr1; expr2} ->
|
||||||
let%bind expr1 = compile_expression expr1 in
|
let%bind expr1 = compile_expression expr1 in
|
||||||
let%bind expr2 = compile_expression expr2 in
|
let%bind expr2 = compile_expression expr2 in
|
||||||
ok @@ add_to_end expr1 expr2
|
ok @@ add_to_end expr1 expr2
|
||||||
| I.E_skip -> return @@ O.E_skip
|
| I.E_skip -> return @@ O.E_skip
|
||||||
|
| I.E_assign ass ->
|
||||||
|
let%bind content = compile_assign ass @@ O.e_skip () in
|
||||||
|
return @@ content
|
||||||
| I.E_for f ->
|
| I.E_for f ->
|
||||||
let%bind f = compile_for f in
|
let%bind f = compile_for f in
|
||||||
return @@ f
|
return @@ f
|
||||||
@ -246,6 +253,37 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
let%bind w = compile_while w in
|
let%bind w = compile_while w in
|
||||||
return @@ w
|
return @@ w
|
||||||
|
|
||||||
|
and compile_assign {variable; access_path; expression} expr =
|
||||||
|
let accessor ?loc s a =
|
||||||
|
match a with
|
||||||
|
I.Access_tuple _i -> failwith "adding tuple soon"
|
||||||
|
| I.Access_record a -> ok @@ O.e_record_accessor ?loc s a
|
||||||
|
| I.Access_map k ->
|
||||||
|
let%bind k = compile_expression k in
|
||||||
|
ok @@ O.e_constant ?loc C_MAP_FIND_OPT [k;s]
|
||||||
|
in
|
||||||
|
let update ?loc (s:O.expression) a e =
|
||||||
|
match a with
|
||||||
|
I.Access_tuple _i -> failwith "adding tuple soon"
|
||||||
|
| I.Access_record a -> ok @@ O.e_record_update ?loc s a e
|
||||||
|
| I.Access_map k ->
|
||||||
|
let%bind k = compile_expression k in
|
||||||
|
ok @@ O.e_constant ?loc C_UPDATE [k;O.e_some (e);s]
|
||||||
|
in
|
||||||
|
let aux (s, e : O.expression * _) lst =
|
||||||
|
let%bind s' = accessor ~loc:s.location s lst in
|
||||||
|
let e' = fun expr ->
|
||||||
|
let%bind u = update ~loc:s.location s lst (expr)
|
||||||
|
in e u
|
||||||
|
in
|
||||||
|
ok @@ (s',e')
|
||||||
|
in
|
||||||
|
let%bind (_,rhs) = bind_fold_list aux (O.e_variable variable, fun e -> ok @@ e) access_path in
|
||||||
|
let%bind expression = compile_expression expression in
|
||||||
|
let%bind rhs = rhs @@ expression in
|
||||||
|
ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false}
|
||||||
|
|
||||||
|
|
||||||
and compile_lambda : I.lambda -> O.lambda result =
|
and compile_lambda : I.lambda -> O.lambda result =
|
||||||
fun {binder;input_type;output_type;result}->
|
fun {binder;input_type;output_type;result}->
|
||||||
let%bind input_type = bind_map_option compile_type_expression input_type in
|
let%bind input_type = bind_map_option compile_type_expression input_type in
|
||||||
@ -362,7 +400,7 @@ and compile_while I.{condition;body} =
|
|||||||
let for_body = add_to_end for_body ctrl in
|
let for_body = add_to_end for_body ctrl in
|
||||||
|
|
||||||
let aux name expr=
|
let aux name expr=
|
||||||
O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable binder) "0") (Var.to_name name)) expr
|
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable binder) "0") (Var.to_name name)) expr
|
||||||
in
|
in
|
||||||
let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in
|
let init_rec = O.e_tuple [store_mutable_variable @@ captured_name_list] in
|
||||||
let restore = fun expr -> List.fold_right aux captured_name_list expr in
|
let restore = fun expr -> List.fold_right aux captured_name_list expr in
|
||||||
@ -377,7 +415,7 @@ and compile_while I.{condition;body} =
|
|||||||
let return_expr = fun expr ->
|
let return_expr = fun expr ->
|
||||||
O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result=
|
O.E_let_in {let_binder; mut=false; inline=false; rhs=init_rec; let_result=
|
||||||
O.e_let_in let_binder false false loop @@
|
O.e_let_in let_binder false false loop @@
|
||||||
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) "0") @@
|
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@
|
||||||
expr
|
expr
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
@ -393,7 +431,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
|
let continue_expr = O.e_constant C_FOLD_CONTINUE [(O.e_variable env_rec)] in
|
||||||
let ctrl =
|
let ctrl =
|
||||||
O.e_let_in (binder,Some O.t_int) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@
|
O.e_let_in (binder,Some O.t_int) false false (O.e_constant C_ADD [ O.e_variable binder ; step ]) @@
|
||||||
O.e_let_in (env_rec, None) false false (O.e_update (O.e_variable env_rec) "1" @@ O.e_variable binder)@@
|
O.e_let_in (env_rec, None) false false (O.e_record_update (O.e_variable env_rec) "1" @@ O.e_variable binder)@@
|
||||||
continue_expr
|
continue_expr
|
||||||
in
|
in
|
||||||
(* Modify the body loop*)
|
(* Modify the body loop*)
|
||||||
@ -402,7 +440,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
let for_body = add_to_end for_body ctrl in
|
let for_body = add_to_end for_body ctrl in
|
||||||
|
|
||||||
let aux name expr=
|
let aux name expr=
|
||||||
O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable env_rec) "0") (Var.to_name name)) expr
|
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable env_rec) "0") (Var.to_name name)) expr
|
||||||
in
|
in
|
||||||
|
|
||||||
(* restores the initial value of the free_var*)
|
(* restores the initial value of the free_var*)
|
||||||
@ -411,7 +449,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
(*Prep the lambda for the fold*)
|
(*Prep the lambda for the fold*)
|
||||||
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
|
let stop_expr = O.e_constant C_FOLD_STOP [O.e_variable env_rec] in
|
||||||
let aux_func = O.e_lambda env_rec None None @@
|
let aux_func = O.e_lambda env_rec None None @@
|
||||||
O.e_let_in (binder,Some O.t_int) false false (O.e_accessor (O.e_variable env_rec) "1") @@
|
O.e_let_in (binder,Some O.t_int) false false (O.e_record_accessor (O.e_variable env_rec) "1") @@
|
||||||
O.e_cond cond (restore for_body) (stop_expr) in
|
O.e_cond cond (restore for_body) (stop_expr) in
|
||||||
|
|
||||||
(* Make the fold_while en precharge the vakye *)
|
(* Make the fold_while en precharge the vakye *)
|
||||||
@ -424,7 +462,7 @@ and compile_for I.{binder;start;final;increment;body} =
|
|||||||
O.E_let_in {let_binder=(binder, Some O.t_int);mut=false; inline=false;rhs=start;let_result=
|
O.E_let_in {let_binder=(binder, Some O.t_int);mut=false; inline=false;rhs=start;let_result=
|
||||||
O.e_let_in let_binder false false init_rec @@
|
O.e_let_in let_binder false false init_rec @@
|
||||||
O.e_let_in let_binder false false loop @@
|
O.e_let_in let_binder false false loop @@
|
||||||
O.e_let_in let_binder false false (O.e_accessor (O.e_variable env_rec) "0") @@
|
O.e_let_in let_binder false false (O.e_record_accessor (O.e_variable env_rec) "0") @@
|
||||||
expr
|
expr
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
@ -440,21 +478,21 @@ and compile_for_each I.{binder;collection;collection_type; body} =
|
|||||||
let env = Var.fresh () in
|
let env = Var.fresh () in
|
||||||
let%bind body = compile_expression body in
|
let%bind body = compile_expression body in
|
||||||
let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in
|
let%bind ((_,free_vars), body) = repair_mutable_variable_in_loops body element_names args in
|
||||||
let for_body = add_to_end body @@ (O.e_accessor (O.e_variable args) "0") in
|
let for_body = add_to_end body @@ (O.e_record_accessor (O.e_variable args) "0") in
|
||||||
|
|
||||||
let init_record = store_mutable_variable free_vars in
|
let init_record = store_mutable_variable free_vars in
|
||||||
let%bind collect = compile_expression collection in
|
let%bind collect = compile_expression collection in
|
||||||
let aux name expr=
|
let aux name expr=
|
||||||
O.e_let_in (name,None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "0") (Var.to_name name)) expr
|
O.e_let_in (name,None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "0") (Var.to_name name)) expr
|
||||||
in
|
in
|
||||||
let restore = fun expr -> List.fold_right aux free_vars expr in
|
let restore = fun expr -> List.fold_right aux free_vars expr in
|
||||||
let restore = match collection_type with
|
let restore = match collection_type with
|
||||||
| Map -> (match snd binder with
|
| Map -> (match snd binder with
|
||||||
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "0")
|
| Some v -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0")
|
||||||
(O.e_let_in (v, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "1") expr))
|
(O.e_let_in (v, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "1") expr))
|
||||||
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_accessor (O.e_variable args) "1") "0") expr)
|
| None -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_record_accessor (O.e_variable args) "1") "0") expr)
|
||||||
)
|
)
|
||||||
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_accessor (O.e_variable args) "1") expr)
|
| _ -> fun expr -> restore (O.e_let_in (fst binder, None) false false (O.e_record_accessor (O.e_variable args) "1") expr)
|
||||||
in
|
in
|
||||||
let lambda = O.e_lambda args None None (restore for_body) in
|
let lambda = O.e_lambda args None None (restore for_body) in
|
||||||
let%bind op_name = match collection_type with
|
let%bind op_name = match collection_type with
|
||||||
@ -564,7 +602,7 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
let%bind ty_opt = bind_map_option uncompile_type_expression ty_opt in
|
||||||
let%bind rhs = uncompile_expression rhs in
|
let%bind rhs = uncompile_expression rhs in
|
||||||
let%bind let_result = uncompile_expression let_result in
|
let%bind let_result = uncompile_expression let_result in
|
||||||
return @@ I.E_let_in {let_binder=(binder,ty_opt);mut=false;inline;rhs;let_result}
|
return @@ I.E_let_in {let_binder=(binder,ty_opt);inline;rhs;let_result}
|
||||||
| O.E_constructor {constructor;element} ->
|
| O.E_constructor {constructor;element} ->
|
||||||
let%bind element = uncompile_expression element in
|
let%bind element = uncompile_expression element in
|
||||||
return @@ I.E_constructor {constructor;element}
|
return @@ I.E_constructor {constructor;element}
|
||||||
@ -581,9 +619,9 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {expr;label} ->
|
| O.E_record_accessor {record;label} ->
|
||||||
let%bind expr = uncompile_expression expr in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {expr;label}
|
return @@ I.E_record_accessor {record;label}
|
||||||
| O.E_record_update {record;path;update} ->
|
| O.E_record_update {record;path;update} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
let%bind update = uncompile_expression update in
|
let%bind update = uncompile_expression update in
|
||||||
|
@ -47,8 +47,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = fold_expression self res update in
|
let%bind res = fold_expression self res update in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_accessor {expr} -> (
|
| E_record_accessor {record} -> (
|
||||||
let%bind res = self init' expr in
|
let%bind res = self init' record in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
@ -134,8 +134,8 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e
|
|||||||
return @@ E_matching {matchee=e';cases=cases'}
|
return @@ E_matching {matchee=e';cases=cases'}
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind e' = self acc.expr in
|
let%bind e' = self acc.record in
|
||||||
return @@ E_record_accessor {acc with expr = e'}
|
return @@ E_record_accessor {acc with record = e'}
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
@ -280,8 +280,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind (res, e') = self init' acc.expr in
|
let%bind (res, e') = self init' acc.record in
|
||||||
ok (res, return @@ E_record_accessor {acc with expr = e'})
|
ok (res, return @@ E_record_accessor {acc with record = e'})
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||||
|
@ -101,9 +101,9 @@ let rec compile_expression : I.expression -> O.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ O.E_record (O.LMap.of_list record)
|
return @@ O.E_record (O.LMap.of_list record)
|
||||||
| I.E_record_accessor {expr;label} ->
|
| I.E_record_accessor {record;label} ->
|
||||||
let%bind expr = compile_expression expr in
|
let%bind record = compile_expression record in
|
||||||
return @@ O.E_record_accessor {expr;label}
|
return @@ O.E_record_accessor {record;label}
|
||||||
| I.E_record_update {record;path;update} ->
|
| I.E_record_update {record;path;update} ->
|
||||||
let%bind record = compile_expression record in
|
let%bind record = compile_expression record in
|
||||||
let%bind update = compile_expression update in
|
let%bind update = compile_expression update in
|
||||||
@ -294,9 +294,9 @@ let rec uncompile_expression : O.expression -> I.expression result =
|
|||||||
) record
|
) record
|
||||||
in
|
in
|
||||||
return @@ I.E_record (O.LMap.of_list record)
|
return @@ I.E_record (O.LMap.of_list record)
|
||||||
| O.E_record_accessor {expr;label} ->
|
| O.E_record_accessor {record;label} ->
|
||||||
let%bind expr = uncompile_expression expr in
|
let%bind record = uncompile_expression record in
|
||||||
return @@ I.E_record_accessor {expr;label}
|
return @@ I.E_record_accessor {record;label}
|
||||||
| O.E_record_update {record;path;update} ->
|
| O.E_record_update {record;path;update} ->
|
||||||
let%bind record = uncompile_expression record in
|
let%bind record = uncompile_expression record in
|
||||||
let%bind update = uncompile_expression update in
|
let%bind update = uncompile_expression update in
|
||||||
|
@ -452,10 +452,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression -
|
|||||||
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
|
* | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ())
|
||||||
* | _ -> return (E_literal (Literal_string s)) (t_string ())
|
* | _ -> return (E_literal (Literal_string s)) (t_string ())
|
||||||
* ) *)
|
* ) *)
|
||||||
| E_record_accessor {expr;label} -> (
|
| E_record_accessor {record;label} -> (
|
||||||
let%bind (base' , state') = type_expression e state expr in
|
let%bind (base' , state') = type_expression e state record in
|
||||||
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
|
let wrapped = Wrap.access_label ~base:base'.type_expression ~label in
|
||||||
return_wrapped (E_record_accessor {expr=base';label}) state' wrapped
|
return_wrapped (E_record_accessor {record=base';label}) state' wrapped
|
||||||
)
|
)
|
||||||
|
|
||||||
(* Sum *)
|
(* Sum *)
|
||||||
@ -1055,8 +1055,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
let%bind r' = bind_smap
|
let%bind r' = bind_smap
|
||||||
@@ Map.String.map untype_expression r in
|
@@ Map.String.map untype_expression r in
|
||||||
return (e_record r')
|
return (e_record r')
|
||||||
| E_record_accessor {expr; label} ->
|
| E_record_accessor {record; label} ->
|
||||||
let%bind r' = untype_expression expr in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = label in
|
let Label s = label in
|
||||||
return (e_accessor r' s)
|
return (e_accessor r' s)
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
|
@ -450,8 +450,8 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
return (e_address s) (t_address ())
|
return (e_address s) (t_address ())
|
||||||
| E_literal (Literal_operation op) ->
|
| E_literal (Literal_operation op) ->
|
||||||
return (e_operation op) (t_operation ())
|
return (e_operation op) (t_operation ())
|
||||||
| E_record_accessor {expr;label} ->
|
| E_record_accessor {record;label} ->
|
||||||
let%bind e' = type_expression' e expr in
|
let%bind e' = type_expression' e record in
|
||||||
let aux (prev:O.expression) (a:I.label) : O.expression result =
|
let aux (prev:O.expression) (a:I.label) : O.expression result =
|
||||||
let property = a in
|
let property = a in
|
||||||
let%bind r_tv = get_t_record prev.type_expression in
|
let%bind r_tv = get_t_record prev.type_expression in
|
||||||
@ -459,7 +459,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
|
|||||||
generic_try (bad_record_access property ae prev.type_expression ae.location)
|
generic_try (bad_record_access property ae prev.type_expression ae.location)
|
||||||
@@ (fun () -> I.LMap.find property r_tv) in
|
@@ (fun () -> I.LMap.find property r_tv) in
|
||||||
let location = ae.location in
|
let location = ae.location in
|
||||||
ok @@ make_a_e ~location (E_record_accessor {expr=prev; label=property}) tv e
|
ok @@ make_a_e ~location (E_record_accessor {record=prev; label=property}) tv e
|
||||||
in
|
in
|
||||||
let%bind ae =
|
let%bind ae =
|
||||||
trace (simple_info "accessing") @@ aux e' label in
|
trace (simple_info "accessing") @@ aux e' label in
|
||||||
@ -861,8 +861,8 @@ let rec untype_expression (e:O.expression) : (I.expression) result =
|
|||||||
let%bind r' = bind_smap
|
let%bind r' = bind_smap
|
||||||
@@ Map.String.map untype_expression r in
|
@@ Map.String.map untype_expression r in
|
||||||
return (e_record r')
|
return (e_record r')
|
||||||
| E_record_accessor {expr; label} ->
|
| E_record_accessor {record; label} ->
|
||||||
let%bind r' = untype_expression expr in
|
let%bind r' = untype_expression record in
|
||||||
let Label s = label in
|
let Label s = label in
|
||||||
return (e_accessor r' s)
|
return (e_accessor r' s)
|
||||||
| E_record_update {record=r; path=l; update=e} ->
|
| E_record_update {record=r; path=l; update=e} ->
|
||||||
|
@ -48,8 +48,8 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini
|
|||||||
let%bind res = fold_expression self res update in
|
let%bind res = fold_expression self res update in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_record_accessor {expr} -> (
|
| E_record_accessor {record} -> (
|
||||||
let%bind res = self init' expr in
|
let%bind res = self init' record in
|
||||||
ok res
|
ok res
|
||||||
)
|
)
|
||||||
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
| E_let_in { let_binder = _ ; rhs ; let_result } -> (
|
||||||
@ -119,8 +119,8 @@ let rec map_expression : mapper -> expression -> expression result = fun f e ->
|
|||||||
return @@ E_matching {matchee=e';cases=cases'}
|
return @@ E_matching {matchee=e';cases=cases'}
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind e' = self acc.expr in
|
let%bind e' = self acc.record in
|
||||||
return @@ E_record_accessor {acc with expr = e'}
|
return @@ E_record_accessor {acc with record = e'}
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind m' = bind_map_lmap self m in
|
let%bind m' = bind_map_lmap self m in
|
||||||
@ -234,8 +234,8 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres
|
|||||||
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
ok (res, return @@ E_matching {matchee=e';cases=cases'})
|
||||||
)
|
)
|
||||||
| E_record_accessor acc -> (
|
| E_record_accessor acc -> (
|
||||||
let%bind (res, e') = self init' acc.expr in
|
let%bind (res, e') = self init' acc.record in
|
||||||
ok (res, return @@ E_record_accessor {acc with expr = e'})
|
ok (res, return @@ E_record_accessor {acc with record = e'})
|
||||||
)
|
)
|
||||||
| E_record m -> (
|
| E_record m -> (
|
||||||
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in
|
||||||
|
@ -49,8 +49,8 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> unit
|
|||||||
let es = LMap.to_list elm in
|
let es = LMap.to_list elm in
|
||||||
let%bind _ = bind_map_list (check_recursive_call n false) es in
|
let%bind _ = bind_map_list (check_recursive_call n false) es in
|
||||||
ok ()
|
ok ()
|
||||||
| E_record_accessor {expr;_} ->
|
| E_record_accessor {record;_} ->
|
||||||
let%bind _ = check_recursive_call n false expr in
|
let%bind _ = check_recursive_call n false record in
|
||||||
ok ()
|
ok ()
|
||||||
| E_record_update {record;update;_} ->
|
| E_record_update {record;update;_} ->
|
||||||
let%bind _ = check_recursive_call n false record in
|
let%bind _ = check_recursive_call n false record in
|
||||||
|
@ -27,8 +27,8 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
c.arguments
|
c.arguments
|
||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor {record; label=l}->
|
||||||
fprintf ppf "%a.%a" expression ra.expr label ra.label
|
fprintf ppf "%a.%a" expression record label l
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
@ -57,15 +57,20 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
expression_variable fun_name
|
expression_variable fun_name
|
||||||
type_expression fun_type
|
type_expression fun_type
|
||||||
expression_content (E_lambda lambda)
|
expression_content (E_lambda lambda)
|
||||||
| E_let_in { let_binder ; mut; rhs ; let_result; inline } ->
|
| E_let_in { let_binder ; rhs ; let_result; inline } ->
|
||||||
fprintf ppf "let %a%a = %a%a in %a" option_mut mut option_type_name let_binder expression rhs option_inline inline expression let_result
|
fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result
|
||||||
| E_ascription {anno_expr; type_annotation} ->
|
| E_ascription {anno_expr; type_annotation} ->
|
||||||
fprintf ppf "%a : %a" expression anno_expr type_expression
|
fprintf ppf "%a : %a" expression anno_expr type_expression
|
||||||
type_annotation
|
type_annotation
|
||||||
| E_sequence {expr1;expr2} ->
|
| E_sequence {expr1;expr2} ->
|
||||||
fprintf ppf "%a;\n%a" expression expr1 expression expr2
|
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
|
||||||
| E_skip ->
|
| E_skip ->
|
||||||
fprintf ppf "skip"
|
fprintf ppf "skip"
|
||||||
|
| E_assign {variable; access_path; expression=e} ->
|
||||||
|
fprintf ppf "%a%a := %a"
|
||||||
|
expression_variable variable
|
||||||
|
(list_sep (fun ppf a -> fprintf ppf ".%a" accessor a) (fun ppf () -> fprintf ppf "")) access_path
|
||||||
|
expression e
|
||||||
| E_for {binder; start; final; increment; body} ->
|
| E_for {binder; start; final; increment; body} ->
|
||||||
fprintf ppf "for %a from %a to %a by %a do %a"
|
fprintf ppf "for %a from %a to %a by %a do %a"
|
||||||
expression_variable binder
|
expression_variable binder
|
||||||
@ -83,6 +88,12 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
expression condition
|
expression condition
|
||||||
expression body
|
expression body
|
||||||
|
|
||||||
|
and accessor ppf a =
|
||||||
|
match a with
|
||||||
|
| Access_tuple i -> fprintf ppf "%d" i
|
||||||
|
| Access_record s -> fprintf ppf "%s" s
|
||||||
|
| Access_map e -> fprintf ppf "%a" expression e
|
||||||
|
|
||||||
and option_map ppf (k,v_opt) =
|
and option_map ppf (k,v_opt) =
|
||||||
match v_opt with
|
match v_opt with
|
||||||
| None -> fprintf ppf "%a" expression_variable k
|
| None -> fprintf ppf "%a" expression_variable k
|
||||||
|
@ -118,12 +118,12 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
|||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
|
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
||||||
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
let e_let_in ?loc (binder, ascr) inline rhs let_result =
|
||||||
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; mut; rhs ; let_result; inline }
|
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline }
|
||||||
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
||||||
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
||||||
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
|
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
|
||||||
@ -191,24 +191,16 @@ let e_lambda ?loc (binder : expression_variable)
|
|||||||
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
||||||
|
|
||||||
|
|
||||||
let e_assign_with_let ?loc var access_path expr =
|
let e_assign ?loc variable access_path expression =
|
||||||
let var = Var.of_name (var) in
|
make_expr ?loc @@ E_assign {variable;access_path;expression}
|
||||||
match access_path with
|
let e_ez_assign ?loc variable access_path expression =
|
||||||
| [] -> (var, None), true, expr, false
|
let variable = Var.of_name variable in
|
||||||
|
let access_path = List.map (fun s -> Access_record s) access_path in
|
||||||
| lst ->
|
e_assign ?loc variable access_path expression
|
||||||
let rec aux path record= match path with
|
|
||||||
| [] -> failwith "acces_path cannot be empty"
|
|
||||||
| [e] -> e_update ?loc record e expr
|
|
||||||
| elem::tail ->
|
|
||||||
let next_record = e_accessor record elem in
|
|
||||||
e_update ?loc record elem (aux tail next_record )
|
|
||||||
in
|
|
||||||
(var, None), true, (aux lst (e_variable var)), false
|
|
||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {expr; label} -> ok (expr , label)
|
| E_record_accessor {record; label} -> ok (record , label)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
|
@ -86,7 +86,7 @@ val e_variable : ?loc:Location.t -> expression_variable -> expression
|
|||||||
val e_skip : ?loc:Location.t -> unit -> expression
|
val e_skip : ?loc:Location.t -> unit -> expression
|
||||||
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
|
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> 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
|
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
|
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
|
||||||
@ -110,7 +110,8 @@ val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option
|
|||||||
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
||||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||||
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
||||||
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
|
val e_assign : ?loc:Location.t -> expression_variable -> access list -> expression -> expression
|
||||||
|
val e_ez_assign : ?loc:Location.t -> string -> string list -> expression -> expression
|
||||||
|
|
||||||
(*
|
(*
|
||||||
val get_e_accessor : expression' -> ( expression * access_path ) result
|
val get_e_accessor : expression' -> ( expression * access_path ) result
|
||||||
|
@ -185,6 +185,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result =
|
|||||||
| (E_recursive _,_) | (E_record_accessor _, _)
|
| (E_recursive _,_) | (E_record_accessor _, _)
|
||||||
| (E_look_up _, _) | (E_matching _, _)
|
| (E_look_up _, _) | (E_matching _, _)
|
||||||
| (E_sequence _, _) | (E_skip, _)
|
| (E_sequence _, _) | (E_skip, _)
|
||||||
|
| (E_assign _, _)
|
||||||
| (E_for _, _) | (E_for_each _, _)
|
| (E_for _, _) | (E_for_each _, _)
|
||||||
| (E_while _, _) -> simple_fail "comparing not a value"
|
| (E_while _, _) -> simple_fail "comparing not a value"
|
||||||
|
|
||||||
|
@ -55,6 +55,7 @@ and expression_content =
|
|||||||
| E_set of expression list
|
| E_set of expression list
|
||||||
| E_look_up of (expression * expression)
|
| E_look_up of (expression * expression)
|
||||||
(* Imperative *)
|
(* Imperative *)
|
||||||
|
| E_assign of assign
|
||||||
| E_for of for_
|
| E_for of for_
|
||||||
| E_for_each of for_each
|
| E_for_each of for_each
|
||||||
| E_while of while_loop
|
| E_while of while_loop
|
||||||
@ -82,14 +83,13 @@ and recursive = {
|
|||||||
|
|
||||||
and let_in =
|
and let_in =
|
||||||
{ let_binder: expression_variable * type_expression option
|
{ let_binder: expression_variable * type_expression option
|
||||||
; mut: bool
|
|
||||||
; rhs: expression
|
; rhs: expression
|
||||||
; let_result: expression
|
; let_result: expression
|
||||||
; inline: bool }
|
; inline: bool }
|
||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {expr: expression; label: label}
|
and accessor = {record: expression; label: label}
|
||||||
|
|
||||||
and update = {record: expression; path: label ; update: expression}
|
and update = {record: expression; path: label ; update: expression}
|
||||||
|
|
||||||
@ -105,6 +105,17 @@ and sequence = {
|
|||||||
expr2: expression ;
|
expr2: expression ;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
and assign = {
|
||||||
|
variable : expression_variable;
|
||||||
|
access_path : access list;
|
||||||
|
expression : expression;
|
||||||
|
}
|
||||||
|
|
||||||
|
and access =
|
||||||
|
| Access_tuple of int
|
||||||
|
| Access_record of string
|
||||||
|
| Access_map of expr
|
||||||
|
|
||||||
and for_ = {
|
and for_ = {
|
||||||
binder : expression_variable;
|
binder : expression_variable;
|
||||||
start : expression;
|
start : expression;
|
||||||
|
@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.expr label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.label
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
@ -64,7 +64,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
option_inline inline
|
option_inline inline
|
||||||
expression let_result
|
expression let_result
|
||||||
| E_sequence {expr1;expr2} ->
|
| E_sequence {expr1;expr2} ->
|
||||||
fprintf ppf "{ %a; %a }" expression expr1 expression expr2
|
fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2
|
||||||
| E_ascription {anno_expr; type_annotation} ->
|
| E_ascription {anno_expr; type_annotation} ->
|
||||||
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
|
fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation
|
||||||
| E_skip ->
|
| E_skip ->
|
||||||
|
@ -107,33 +107,27 @@ let e_bytes_raw ?loc (b: bytes) : expression =
|
|||||||
make_expr ?loc @@ E_literal (Literal_bytes b)
|
make_expr ?loc @@ E_literal (Literal_bytes b)
|
||||||
let e_bytes_string ?loc (s: string) : expression =
|
let e_bytes_string ?loc (s: string) : expression =
|
||||||
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
|
make_expr ?loc @@ E_literal (Literal_bytes (Hex.to_bytes (Hex.of_string s)))
|
||||||
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
|
|
||||||
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
|
let e_some ?loc s : expression = make_expr ?loc @@ E_constant {cons_name = C_SOME; arguments = [s]}
|
||||||
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
|
let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NONE; arguments = []}
|
||||||
let e_string_cat ?loc sl sr : expression = make_expr ?loc @@ E_constant {cons_name = C_CONCAT; arguments = [sl ; sr ]}
|
|
||||||
let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_name = C_MAP_ADD; arguments = [k ; v ; old]}
|
|
||||||
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
|
|
||||||
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
|
|
||||||
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
|
||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
|
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
|
||||||
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
let e_let_in ?loc (binder, ascr) mut inline rhs let_result =
|
||||||
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
|
make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut }
|
||||||
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
|
||||||
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
let e_application ?loc a b = make_expr ?loc @@ E_application {lamb=a ; args=b}
|
||||||
let e_binop ?loc name a b = make_expr ?loc @@ E_constant {cons_name = name ; arguments = [a ; b]}
|
|
||||||
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
|
let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; arguments = lst}
|
||||||
let e_look_up ?loc x y = make_expr ?loc @@ E_look_up (x , y)
|
|
||||||
|
let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty}
|
||||||
|
|
||||||
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2}
|
let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2}
|
||||||
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
|
let e_skip ?loc () = make_expr ?loc @@ E_skip
|
||||||
(*
|
|
||||||
let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*)
|
let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
||||||
*)
|
let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst
|
||||||
|
let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst
|
||||||
|
let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst
|
||||||
|
|
||||||
let ez_match_variant (lst : ((string * string) * 'a) list) =
|
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
|
let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in
|
||||||
Match_variant (lst,())
|
Match_variant (lst,())
|
||||||
@ -145,19 +139,20 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression =
|
|||||||
let e_record ?loc map =
|
let e_record ?loc map =
|
||||||
let lst = Map.String.to_kv_list map in
|
let lst = Map.String.to_kv_list map in
|
||||||
e_record_ez ?loc lst
|
e_record_ez ?loc lst
|
||||||
|
let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
||||||
|
|
||||||
let e_update ?loc record path update =
|
let e_record_update ?loc record path update =
|
||||||
let path = Label path in
|
let path = Label path in
|
||||||
make_expr ?loc @@ E_record_update {record; path; update}
|
make_expr ?loc @@ E_record_update {record; path; update}
|
||||||
|
|
||||||
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
|
|
||||||
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
|
||||||
|
|
||||||
let make_option_typed ?loc e t_opt =
|
let make_option_typed ?loc e t_opt =
|
||||||
match t_opt with
|
match t_opt with
|
||||||
| None -> e
|
| None -> e
|
||||||
| Some t -> e_annotation ?loc e t
|
| Some t -> e_annotation ?loc e t
|
||||||
|
|
||||||
|
let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false})
|
||||||
|
let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst)
|
||||||
|
let e_pair ?loc a b : expression = e_tuple ?loc [a;b]
|
||||||
|
|
||||||
let e_typed_none ?loc t_opt =
|
let e_typed_none ?loc t_opt =
|
||||||
let type_annotation = t_option t_opt in
|
let type_annotation = t_option t_opt in
|
||||||
@ -185,25 +180,9 @@ let e_lambda ?loc (binder : expression_variable)
|
|||||||
}
|
}
|
||||||
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda}
|
||||||
|
|
||||||
|
|
||||||
let e_assign_with_let ?loc var access_path expr =
|
|
||||||
let var = Var.of_name (var) in
|
|
||||||
match access_path with
|
|
||||||
| [] -> (var, None), true, expr, false
|
|
||||||
|
|
||||||
| lst ->
|
|
||||||
let rec aux path record= match path with
|
|
||||||
| [] -> failwith "acces_path cannot be empty"
|
|
||||||
| [e] -> e_update ?loc record e expr
|
|
||||||
| elem::tail ->
|
|
||||||
let next_record = e_accessor record elem in
|
|
||||||
e_update ?loc record elem (aux tail next_record )
|
|
||||||
in
|
|
||||||
(var, None), true, (aux lst (e_variable var)), false
|
|
||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {expr; label} -> ok (expr , label)
|
| E_record_accessor {record; label} -> ok (record , label)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
|
@ -65,34 +65,34 @@ val e'_bytes : string -> expression_content result
|
|||||||
val e_bytes_hex : ?loc:Location.t -> string -> expression result
|
val e_bytes_hex : ?loc:Location.t -> string -> expression result
|
||||||
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
|
val e_bytes_raw : ?loc:Location.t -> bytes -> expression
|
||||||
val e_bytes_string : ?loc:Location.t -> string -> expression
|
val e_bytes_string : ?loc:Location.t -> string -> expression
|
||||||
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
|
||||||
|
|
||||||
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
|
|
||||||
val e_tuple : ?loc:Location.t -> expression list -> expression
|
|
||||||
val e_some : ?loc:Location.t -> expression -> expression
|
val e_some : ?loc:Location.t -> expression -> expression
|
||||||
val e_none : ?loc:Location.t -> unit -> expression
|
val e_none : ?loc:Location.t -> unit -> expression
|
||||||
val e_string_cat : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val e_map_add : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
||||||
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
|
||||||
val e_set : ?loc:Location.t -> expression list -> expression
|
|
||||||
val e_list : ?loc:Location.t -> expression list -> expression
|
|
||||||
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
val e_constructor : ?loc:Location.t -> string -> expression -> expression
|
||||||
|
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
|
||||||
|
|
||||||
|
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
|
||||||
|
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
||||||
|
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
||||||
|
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
|
||||||
|
|
||||||
|
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
||||||
|
val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
||||||
|
val e_record_accessor : ?loc:Location.t -> expression -> string -> expression
|
||||||
|
|
||||||
|
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
||||||
|
|
||||||
|
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
|
||||||
|
val e_skip : ?loc:Location.t -> unit -> expression
|
||||||
|
|
||||||
|
val e_list : ?loc:Location.t -> expression list -> expression
|
||||||
|
val e_set : ?loc:Location.t -> expression list -> expression
|
||||||
|
val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression
|
||||||
|
val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression
|
||||||
|
|
||||||
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
|
||||||
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_accessor : ?loc:Location.t -> expression -> string -> expression
|
|
||||||
val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression
|
|
||||||
val e_variable : ?loc:Location.t -> expression_variable -> expression
|
|
||||||
val e_skip : ?loc:Location.t -> unit -> expression
|
|
||||||
val e_sequence : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
|
||||||
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> bool -> expression -> expression -> expression
|
|
||||||
val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression
|
|
||||||
val e_application : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val e_binop : ?loc:Location.t -> constant' -> expression -> expression -> expression
|
|
||||||
val e_constant : ?loc:Location.t -> constant' -> expression list -> expression
|
|
||||||
val e_look_up : ?loc:Location.t -> expression -> expression -> expression
|
|
||||||
val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content
|
|
||||||
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression
|
||||||
|
|
||||||
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
|
val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression
|
||||||
@ -103,15 +103,12 @@ val e_typed_list : ?loc:Location.t -> expression list -> type_expression -> expr
|
|||||||
|
|
||||||
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
val e_typed_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
||||||
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> type_expression -> type_expression -> expression
|
||||||
|
|
||||||
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
|
val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression
|
||||||
|
|
||||||
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
|
val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression
|
||||||
val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression
|
val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression
|
||||||
val e_record : ?loc:Location.t -> expr Map.String.t -> expression
|
val e_tuple : ?loc:Location.t -> expression list -> expression
|
||||||
val e_update : ?loc:Location.t -> expression -> string -> expression -> expression
|
val e_pair : ?loc:Location.t -> expression -> expression -> expression
|
||||||
val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool)
|
|
||||||
|
|
||||||
(*
|
(*
|
||||||
val get_e_accessor : expression' -> ( expression * access_path ) result
|
val get_e_accessor : expression' -> ( expression * access_path ) result
|
||||||
*)
|
*)
|
||||||
|
@ -86,7 +86,7 @@ and let_in = {
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {expr: expression; label: label}
|
and accessor = {record: expression; label: label}
|
||||||
|
|
||||||
and update = {record: expression; path: label ; update: expression}
|
and update = {record: expression; path: label ; update: expression}
|
||||||
|
|
||||||
|
@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.expr label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.label
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
|
@ -118,7 +118,7 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst
|
|||||||
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a}
|
||||||
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b}
|
||||||
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c})
|
||||||
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {expr = a; label= Label b}
|
let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b}
|
||||||
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b
|
||||||
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
let e_variable ?loc v = make_expr ?loc @@ E_variable v
|
||||||
let e_let_in ?loc (binder, ascr) inline rhs let_result =
|
let e_let_in ?loc (binder, ascr) inline rhs let_result =
|
||||||
@ -201,7 +201,7 @@ let e_assign_with_let ?loc var access_path expr =
|
|||||||
|
|
||||||
let get_e_accessor = fun t ->
|
let get_e_accessor = fun t ->
|
||||||
match t with
|
match t with
|
||||||
| E_record_accessor {expr; label} -> ok (expr , label)
|
| E_record_accessor {record; label} -> ok (record , label)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let assert_e_accessor = fun t ->
|
let assert_e_accessor = fun t ->
|
||||||
|
@ -82,7 +82,7 @@ and let_in =
|
|||||||
|
|
||||||
and constructor = {constructor: constructor'; element: expression}
|
and constructor = {constructor: constructor'; element: expression}
|
||||||
|
|
||||||
and accessor = {expr: expression; label: label}
|
and accessor = {record: expression; label: label}
|
||||||
|
|
||||||
and update = {record: expression; path: label ; update: expression}
|
and update = {record: expression; path: label ; update: expression}
|
||||||
|
|
||||||
|
@ -29,7 +29,7 @@ and expression_content ppf (ec: expression_content) =
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
fprintf ppf "%a" (tuple_or_record_sep_expr expression) m
|
||||||
| E_record_accessor ra ->
|
| E_record_accessor ra ->
|
||||||
fprintf ppf "%a.%a" expression ra.expr label ra.label
|
fprintf ppf "%a.%a" expression ra.record label ra.label
|
||||||
| E_record_update {record; path; update} ->
|
| E_record_update {record; path; update} ->
|
||||||
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update
|
||||||
| E_map m ->
|
| E_map m ->
|
||||||
|
@ -337,7 +337,7 @@ let get_a_bool (t:expression) =
|
|||||||
|
|
||||||
let get_a_record_accessor = fun t ->
|
let get_a_record_accessor = fun t ->
|
||||||
match t.expression_content with
|
match t.expression_content with
|
||||||
| E_record_accessor {expr ; label} -> ok (expr , label)
|
| E_record_accessor {record ; label} -> ok (record , label)
|
||||||
| _ -> simple_fail "not an accessor"
|
| _ -> simple_fail "not an accessor"
|
||||||
|
|
||||||
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
|
let get_declaration_by_name : program -> string -> declaration result = fun p name ->
|
||||||
|
@ -209,7 +209,7 @@ module Free_variables = struct
|
|||||||
| E_application {lamb;args} -> unions @@ List.map self [ lamb ; args ]
|
| E_application {lamb;args} -> unions @@ List.map self [ lamb ; args ]
|
||||||
| E_constructor {element;_} -> self element
|
| E_constructor {element;_} -> self element
|
||||||
| E_record m -> unions @@ List.map self @@ LMap.to_list m
|
| E_record m -> unions @@ List.map self @@ LMap.to_list m
|
||||||
| E_record_accessor {expr;_} -> self expr
|
| E_record_accessor {record;_} -> self record
|
||||||
| E_record_update {record; update;_} -> union (self record) @@ self update
|
| E_record_update {record; update;_} -> union (self record) @@ self update
|
||||||
| E_list lst -> unions @@ List.map self lst
|
| E_list lst -> unions @@ List.map self lst
|
||||||
| E_set lst -> unions @@ List.map self lst
|
| E_set lst -> unions @@ List.map self lst
|
||||||
|
@ -70,7 +70,7 @@ module Captured_variables = struct
|
|||||||
| E_record m ->
|
| E_record m ->
|
||||||
let%bind lst' = bind_map_list self @@ LMap.to_list m in
|
let%bind lst' = bind_map_list self @@ LMap.to_list m in
|
||||||
ok @@ unions lst'
|
ok @@ unions lst'
|
||||||
| E_record_accessor {expr;_} -> self expr
|
| E_record_accessor {record;_} -> self record
|
||||||
| E_record_update {record;update;_} ->
|
| E_record_update {record;update;_} ->
|
||||||
let%bind r = self record in
|
let%bind r = self record in
|
||||||
let%bind e = self update in
|
let%bind e = self update in
|
||||||
|
@ -92,7 +92,7 @@ and constructor = {
|
|||||||
}
|
}
|
||||||
|
|
||||||
and accessor = {
|
and accessor = {
|
||||||
expr: expression ;
|
record: expression ;
|
||||||
label: label ;
|
label: label ;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -182,10 +182,10 @@ module Substitution = struct
|
|||||||
* let val_ = s_expression ~v ~expr val_ in
|
* let val_ = s_expression ~v ~expr val_ in
|
||||||
* ok @@ (key , val_)) aemap in
|
* ok @@ (key , val_)) aemap in
|
||||||
* ok @@ T.E_record aemap *)
|
* ok @@ T.E_record aemap *)
|
||||||
| T.E_record_accessor {expr=e;label} ->
|
| T.E_record_accessor {record=e;label} ->
|
||||||
let%bind expr = s_expression ~substs e in
|
let%bind record = s_expression ~substs e in
|
||||||
let%bind label = s_label ~substs label in
|
let%bind label = s_label ~substs label in
|
||||||
ok @@ T.E_record_accessor {expr;label}
|
ok @@ T.E_record_accessor {record;label}
|
||||||
| T.E_record_update {record;path;update}->
|
| T.E_record_update {record;path;update}->
|
||||||
let%bind record = s_expression ~substs record in
|
let%bind record = s_expression ~substs record in
|
||||||
let%bind update = s_expression ~substs update in
|
let%bind update = s_expression ~substs update in
|
||||||
|
@ -33,7 +33,7 @@ let empty_message = e_lambda (Var.of_name "arguments")
|
|||||||
empty_op_list
|
empty_op_list
|
||||||
let empty_message2 = e_lambda (Var.of_name "arguments")
|
let empty_message2 = e_lambda (Var.of_name "arguments")
|
||||||
(Some t_bytes) (Some (t_list t_operation))
|
(Some t_bytes) (Some (t_list t_operation))
|
||||||
( e_let_in ((Var.of_name "foo"),Some t_unit) false false (e_unit ()) empty_op_list)
|
( e_let_in ((Var.of_name "foo"),Some t_unit) false (e_unit ()) empty_op_list)
|
||||||
|
|
||||||
let send_param msg = e_constructor "Send" msg
|
let send_param msg = e_constructor "Send" msg
|
||||||
let withdraw_param = e_constructor "Withdraw" empty_message
|
let withdraw_param = e_constructor "Withdraw" empty_message
|
||||||
|
Loading…
Reference in New Issue
Block a user