Merge branch 'dev' of gitlab.com:ligolang/ligo into rinderknecht@pprint_comments

This commit is contained in:
Christian Rinderknecht 2020-07-01 20:49:05 +02:00
commit 6c50ec0ed1
51 changed files with 299 additions and 238 deletions

View File

@ -22,7 +22,7 @@ let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem
ok @@ (ae_typed',state) ok @@ (ae_typed',state)
let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result = let apply (entry_point : string) (param : Ast_core.expression) : (Ast_core.expression , _) result =
let name = Var.of_name entry_point in let name = Location.wrap @@ Var.of_name entry_point in
let entry_point_var : Ast_core.expression = let entry_point_var : Ast_core.expression =
{ content = Ast_core.E_variable name ; { content = Ast_core.E_variable name ;
sugar = None ; sugar = None ;
@ -39,6 +39,6 @@ let list_declarations (program : Ast_core.program) : string list =
let open Location in let open Location in
let open Ast_core in let open Ast_core in
match el.wrap_content with match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev
| _ -> prev) | _ -> prev)
[] program [] program

View File

@ -17,6 +17,6 @@ let list_declarations (program : program) : string list =
(fun prev el -> (fun prev el ->
let open Location in let open Location in
match el.wrap_content with match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev
| _ -> prev) | _ -> prev)
[] program [] program

View File

@ -14,6 +14,6 @@ let list_declarations (program : program) : string list =
(fun prev el -> (fun prev el ->
let open Location in let open Location in
match el.wrap_content with match el.wrap_content with
| Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev
| _ -> prev) | _ -> prev)
[] program [] program

View File

@ -195,7 +195,7 @@ let rec compile_expression :
let (p , loc) = r_split p in let (p , loc) = r_split p in
let var = let var =
let name = Var.of_name p.struct_name.value in let name = Var.of_name p.struct_name.value in
e_variable ~loc name in e_variable ~loc (Location.wrap ?loc:(Some loc) name) in
let path = p.field_path in let path = p.field_path in
let path' = let path' =
let aux (s:Raw.selection) = let aux (s:Raw.selection) =
@ -222,7 +222,7 @@ let rec compile_expression :
let compile_update (u: Raw.update Region.reg) = let compile_update (u: Raw.update Region.reg) =
let u, loc = r_split u in let u, loc = r_split u in
let name, path = compile_path u.record in let name, path = compile_path u.record in
let var = e_variable (Var.of_name name) in let var = e_variable (Location.wrap ?loc:(Some loc) @@ Var.of_name name) in
let record = if path = [] then var else e_accessor var path in let record = if path = [] then var else e_accessor var path in
let updates = u.updates.value.ne_elements in let updates = u.updates.value.ne_elements in
let%bind updates' = let%bind updates' =
@ -248,7 +248,7 @@ in trace (abstracting_expr_tracer t) @@
let%bind ty_opt = let%bind ty_opt =
bind_map_option (fun (re,te) -> let%bind te = compile_type_expression te in ok(Location.lift re,te)) lhs_type in bind_map_option (fun (re,te) -> let%bind te = compile_type_expression te in ok(Location.lift re,te)) lhs_type in
let%bind rhs = compile_expression let_rhs in let%bind rhs = compile_expression let_rhs in
let rhs_b = Var.fresh ~name:"rhs" () in let rhs_b = Location.wrap @@ Var.fresh ~name:"rhs" () in
let rhs',rhs_b_expr = let rhs',rhs_b_expr =
match ty_opt with match ty_opt with
None -> rhs, e_variable ~loc rhs_b None -> rhs, e_variable ~loc rhs_b
@ -256,7 +256,8 @@ in trace (abstracting_expr_tracer t) @@
let%bind body = compile_expression body in let%bind body = compile_expression body in
let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = let prepare_variable (ty_var: Raw.variable * Raw.type_expr option) =
let variable, ty_opt = ty_var in let variable, ty_opt = ty_var in
let var_expr = Var.of_name variable.value in let (variable,loc) = r_split variable in
let var_expr = Location.wrap ?loc:(Some loc) @@ Var.of_name variable in
let%bind ty_expr_opt = let%bind ty_expr_opt =
match ty_opt with match ty_opt with
| Some ty -> bind_map_option compile_type_expression (Some ty) | Some ty -> bind_map_option compile_type_expression (Some ty)
@ -343,7 +344,7 @@ in trace (abstracting_expr_tracer t) @@
| EVar c -> | EVar c ->
let (c',loc) = r_split c in let (c',loc) = r_split c in
(match constants c' with (match constants c' with
| None -> return @@ e_variable ~loc (Var.of_name c.value) | None -> return @@ e_variable ~loc (Location.wrap ?loc:(Some loc) @@ Var.of_name c.value)
| Some s -> return @@ e_constant s []) | Some s -> return @@ e_constant s [])
| ECall x -> ( | ECall x -> (
let ((e1 , e2) , loc) = r_split x in let ((e1 , e2) , loc) = r_split x in
@ -357,7 +358,7 @@ in trace (abstracting_expr_tracer t) @@
| EVar f -> ( | EVar f -> (
let (f , f_loc) = r_split f in let (f , f_loc) = r_split f in
match constants f with match constants f with
| None -> return @@ chain_application (e_variable ~loc:f_loc (Var.of_name f)) args | None -> return @@ chain_application (e_variable ~loc:f_loc (Location.wrap ?loc:(Some f_loc) @@ Var.of_name f)) args
| Some s -> return @@ e_constant ~loc s args | Some s -> return @@ e_constant ~loc s args
) )
| e1 -> | e1 ->
@ -463,7 +464,8 @@ in trace (abstracting_expr_tracer t) @@
let x' = x.value in let x' = x.value in
match x'.pattern with match x'.pattern with
| Raw.PVar y -> | Raw.PVar y ->
let var_name = Var.of_name y.value in let (y,loc) = r_split y in
let var_name = Location.wrap ?loc:(Some loc) @@ Var.of_name y 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 e rhs return @@ e_let_in (var_name , Some type_expr) false e rhs
| _ -> default_action () | _ -> default_action ()
@ -603,8 +605,9 @@ and compile_fun lamb' : (expr , abs_error) result =
let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = let rec layer_arguments (arguments: (Raw.variable * type_expression) list) =
match arguments with match arguments with
| hd :: tl -> | hd :: tl ->
let (hd_binder,hd_loc) = r_split (fst hd) in
let (binder , input_type) = let (binder , input_type) =
(Var.of_name (fst hd).value , snd hd) in (Location.wrap ?loc:(Some hd_loc) @@ Var.of_name hd_binder , snd hd) in
e_lambda ~loc (binder) (Some input_type) output_type (layer_arguments tl) e_lambda ~loc (binder) (Some input_type) output_type (layer_arguments tl)
| [] -> body | [] -> body
in in
@ -705,7 +708,8 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a
| None -> ok None | None -> ok None
in in
let%bind compile_rhs_expr = compile_expression rhs_expr in let%bind compile_rhs_expr = compile_expression rhs_expr in
ok @@ loc x @@ Declaration_constant (Var.of_name v.value, v_type_expression, inline, compile_rhs_expr) ) let (v_binder,v_loc) = r_split v in
ok @@ loc x @@ Declaration_constant (Location.wrap ?loc:(Some v_loc) @@ Var.of_name v_binder, v_type_expression, inline, compile_rhs_expr) )
in let%bind variables = ok @@ npseq_to_list pt.value in let%bind variables = ok @@ npseq_to_list pt.value
in let%bind expr_bind_lst = in let%bind expr_bind_lst =
match let_rhs with match let_rhs with
@ -789,7 +793,8 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a
) )
| Some t -> ok @@ Some t | Some t -> ok @@ Some t
in in
let binder = Var.of_name var.value in let (var_binder, var_loc) = r_split var in
let fun_name = Location.wrap ?loc:(Some var_loc) @@ Var.of_name var_binder in
let%bind rhs' = match recursive with let%bind rhs' = match recursive with
None -> ok @@ rhs' None -> ok @@ rhs'
| Some _ -> match rhs'.expression_content with | Some _ -> match rhs'.expression_content with
@ -797,11 +802,11 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a
(match lhs_type with (match lhs_type with
None -> fail @@ untyped_recursive_fun var.Region.region None -> fail @@ untyped_recursive_fun var.Region.region
| Some (lhs_type) -> | Some (lhs_type) ->
let expression_content = E_recursive {fun_name=binder;fun_type=lhs_type;lambda} in let expression_content = E_recursive {fun_name;fun_type=lhs_type;lambda} in
ok @@ {rhs' with expression_content}) ok @@ {rhs' with expression_content})
| _ -> ok @@ rhs' | _ -> ok @@ rhs'
in in
ok @@ [loc x @@ (Declaration_constant (Var.of_name var.value , lhs_type , inline, rhs'))] ok @@ [loc x @@ (Declaration_constant (fun_name , lhs_type , inline, rhs'))]
) )
and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error) result = and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error) result =
@ -840,8 +845,7 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error
let%bind pat = let%bind pat =
trace_option (unsupported_cst_constr t) @@ pat_opt in trace_option (unsupported_cst_constr t) @@ pat_opt in
let%bind single_pat = get_single pat in let%bind single_pat = get_single pat in
let%bind var = get_var single_pat in ok (const.value, single_pat)
ok (const.value, var)
| _ -> fail @@ only_constructors t in | _ -> fail @@ only_constructors t in
let rec get_constr_opt (t:Raw.pattern) = let rec get_constr_opt (t:Raw.pattern) =
match t with match t with
@ -859,8 +863,7 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error
| None -> ok None | None -> ok None
| Some pat -> | Some pat ->
let%bind single_pat = get_single pat in let%bind single_pat = get_single pat in
let%bind var = get_var single_pat in ok (Some single_pat)
ok (Some var)
in ok (const.value , var_opt) in ok (const.value , var_opt)
| _ -> fail @@ only_constructors t in | _ -> fail @@ only_constructors t in
let%bind patterns = let%bind patterns =
@ -873,7 +876,8 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error
match patterns with match patterns with
| [(PFalse _, f) ; (PTrue _, t)] | [(PFalse _, f) ; (PTrue _, t)]
| [(PTrue _, t) ; (PFalse _, f)] -> | [(PTrue _, t) ; (PFalse _, f)] ->
ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)]) let muted = Location.wrap @@ Var.of_name "_" in
ok @@ Match_variant ([((Constructor "true", muted), t); ((Constructor "false", muted), f)])
| [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)] | [(PList (PCons c), cons); (PList (PListComp sugar_nil), nil)]
| [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] -> | [(PList (PListComp sugar_nil), nil); (PList (PCons c), cons)] ->
let%bind () = let%bind () =
@ -882,19 +886,26 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error
@@ sugar_nil.value.elements in @@ sugar_nil.value.elements in
let%bind (a, b) = let%bind (a, b) =
let a, _, b = c.value in let a, _, b = c.value in
let a_loc = Location.lift (Raw.pattern_to_region a) in
let b_loc = Location.lift (Raw.pattern_to_region b) in
let%bind a = get_var a in let%bind a = get_var a in
let%bind b = get_var b in let%bind b = get_var b in
let a = Location.wrap ?loc:(Some a_loc) @@ Var.of_name a in
let b = Location.wrap ?loc:(Some b_loc) @@ Var.of_name b in
ok (a, 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=(a, b, cons); match_nil=nil}
| lst -> | lst ->
let as_variant () = let as_variant () =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@ trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let%bind constrs = let%bind constrs =
let aux (x, y) = let aux (x, y) =
let%bind x' = get_constr x let%bind (c,v) = get_constr x in
in ok (x', y) let v_loc = Location.lift (Raw.pattern_to_region v) in
let%bind v = get_var v in
let v' = Location.wrap ?loc:(Some v_loc) @@ Var.of_name v in
ok ((Constructor c, v'), y)
in bind_map_list aux lst in bind_map_list aux lst
in ok @@ ez_match_variant constrs in in ok @@ Match_variant constrs in
let as_option () = let as_option () =
trace_strong (unsupported_pattern_type (List.map fst lst)) @@ trace_strong (unsupported_pattern_type (List.map fst lst)) @@
let aux (x, y) = let aux (x, y) =
@ -906,8 +917,11 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error
(("None" , None) , none_expr) ] (("None" , None) , none_expr) ]
| [ (("None", None), none_expr); | [ (("None", None), none_expr);
(("Some", Some some_var), some_expr) ] -> (("Some", Some some_var), some_expr) ] ->
let var_loc = Location.lift (Raw.pattern_to_region some_var) in
let%bind var_binder = get_var some_var in
let proj = Location.wrap ?loc:(Some var_loc) @@ Var.of_name var_binder in
ok @@ Match_option { ok @@ Match_option {
match_some = (Var.of_name some_var, some_expr); match_some = (proj, some_expr);
match_none = none_expr } match_none = none_expr }
| _ -> fail @@ corner_case "bad option pattern" | _ -> fail @@ corner_case "bad option pattern"
in bind_or (as_option () , as_variant ()) in bind_or (as_option () , as_variant ())

View File

@ -98,7 +98,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let get_e_variable : AST.expression -> _ result = fun expr -> let get_e_variable : AST.expression -> _ result = fun expr ->
match expr.expression_content with match expr.expression_content with
E_variable var -> ok @@ var E_variable var -> ok @@ var.wrap_content
| _ -> failwith @@ | _ -> failwith @@
Format.asprintf "%a should be a variable expression" Format.asprintf "%a should be a variable expression"
AST.PP.expression expr AST.PP.expression expr
@ -127,7 +127,7 @@ let rec decompile_expression : AST.expression -> _ result = fun expr ->
let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in let return_expr_with_par expr = return_expr @@ CST.EPar (wrap @@ par @@ expr) in
match expr.expression_content with match expr.expression_content with
E_variable name -> E_variable name ->
let var = decompile_variable name in let var = decompile_variable name.wrap_content in
return_expr @@ CST.EVar (var) return_expr @@ CST.EVar (var)
| E_constant {cons_name; arguments} -> | E_constant {cons_name; arguments} ->
let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
@ -194,7 +194,7 @@ let rec decompile_expression : AST.expression -> _ result = fun expr ->
| E_recursive _ -> | E_recursive _ ->
failwith "corner case : annonymous recursive function" failwith "corner case : annonymous recursive function"
| E_let_in {let_binder;rhs;let_result;inline} -> | E_let_in {let_binder;rhs;let_result;inline} ->
let var = CST.PVar (decompile_variable @@ fst let_binder) in let var = CST.PVar (decompile_variable @@ (fst let_binder).wrap_content) in
let binders = (var,[]) in let binders = (var,[]) in
let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) @@ snd let_binder in let%bind lhs_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) @@ snd let_binder in
let%bind let_rhs = decompile_expression rhs in let%bind let_rhs = decompile_expression rhs in
@ -263,7 +263,7 @@ let rec decompile_expression : AST.expression -> _ result = fun expr ->
Access_record var::path -> ok @@ (var,path) Access_record var::path -> ok @@ (var,path)
| _ -> failwith "Impossible case %a" | _ -> failwith "Impossible case %a"
in in
let%bind field_path = decompile_to_path (Var.of_name var) path in let%bind field_path = decompile_to_path (Location.wrap @@ Var.of_name var) path in
let%bind field_expr = decompile_expression update in let%bind field_expr = decompile_expression update in
let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = updates.value.ne_elements in let updates = updates.value.ne_elements in
@ -382,7 +382,7 @@ let rec decompile_expression : AST.expression -> _ result = fun expr ->
AST.PP.expression expr AST.PP.expression expr
and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access -> and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
let struct_name = decompile_variable var in let struct_name = decompile_variable var.wrap_content in
match access with match access with
[] -> ok @@ CST.Name struct_name [] -> ok @@ CST.Name struct_name
| lst -> | lst ->
@ -399,7 +399,7 @@ and decompile_to_selection : AST.access -> (CST.selection, _) result = fun acces
"Can't decompile access_map to selection" "Can't decompile access_map to selection"
and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} -> and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
let%bind param_decl = pattern_type binder input_type in let%bind param_decl = pattern_type binder.wrap_content input_type in
let param = (param_decl, []) in let param = (param_decl, []) in
let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in let%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type in
let%bind return = decompile_expression result in let%bind return = decompile_expression result in
@ -413,7 +413,7 @@ and decompile_matching_cases : AST.matching_expr -> ((CST.expr CST.case_clause R
fun m -> fun m ->
let%bind cases = match m with let%bind cases = match m with
Match_variable (var, ty_opt, expr) -> Match_variable (var, ty_opt, expr) ->
let%bind pattern = pattern_type var ty_opt in let%bind pattern = pattern_type var.wrap_content ty_opt in
let%bind rhs = decompile_expression expr in let%bind rhs = decompile_expression expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case] ok @@ [wrap case]
@ -425,9 +425,9 @@ fun m ->
let%bind type_expr = decompile_type_expr ty in let%bind type_expr = decompile_type_expr ty in
ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr}) ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr})
in in
bind list_to_nsepseq @@ bind_map_list aux @@ List.combine lst ty_lst bind list_to_nsepseq @@ bind_map_list aux @@ List.combine (List.map (fun (e:AST.expression_variable) -> e.wrap_content) lst) ty_lst
| None -> | None ->
let aux var = CST.PVar (decompile_variable var) in let aux (var:AST.expression_variable) = CST.PVar (decompile_variable var.wrap_content) in
list_to_nsepseq @@ List.map aux lst list_to_nsepseq @@ List.map aux lst
in in
let pattern : CST.pattern = PTuple (wrap @@ tuple) in let pattern : CST.pattern = PTuple (wrap @@ tuple) in
@ -439,13 +439,13 @@ fun m ->
let%bind rhs = decompile_expression match_none in let%bind rhs = decompile_expression match_none in
let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
let%bind rhs = decompile_expression @@ snd match_some in let%bind rhs = decompile_expression @@ snd match_some in
let var = CST.PVar (decompile_variable @@ fst match_some)in let var = CST.PVar (decompile_variable @@ (fst match_some).wrap_content)in
let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
ok @@ [wrap some_case;wrap none_case] ok @@ [wrap some_case;wrap none_case]
| Match_list {match_nil; match_cons} -> | Match_list {match_nil; match_cons} ->
let (hd,tl,expr) = match_cons in let (hd,tl,expr) = match_cons in
let hd = CST.PVar (decompile_variable hd) in let hd = CST.PVar (decompile_variable hd.wrap_content) in
let tl = CST.PVar (decompile_variable tl) in let tl = CST.PVar (decompile_variable tl.wrap_content) in
let cons = (hd,rg,tl) in let cons = (hd,rg,tl) in
let%bind rhs = decompile_expression @@ expr in let%bind rhs = decompile_expression @@ expr in
let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
@ -453,10 +453,10 @@ fun m ->
let nil_case : _ CST.case_clause = {pattern=PList (PListComp (wrap @@ inject brackets None));arrow=rg; rhs} in let nil_case : _ CST.case_clause = {pattern=PList (PListComp (wrap @@ inject brackets None));arrow=rg; rhs} in
ok @@ [wrap cons_case; wrap nil_case] ok @@ [wrap cons_case; wrap nil_case]
| Match_variant lst -> | Match_variant lst ->
let aux ((c,v),e) = let aux ((c,(v:AST.expression_variable)),e) =
let AST.Constructor c = c in let AST.Constructor c = c in
let constr = wrap @@ c in let constr = wrap @@ c in
let var : CST.pattern = PVar (decompile_variable v) in let var : CST.pattern = PVar (decompile_variable v.wrap_content) in
let tuple = var in let tuple = var in
let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
let%bind rhs = decompile_expression e in let%bind rhs = decompile_expression e in
@ -476,7 +476,7 @@ let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _
ok @@ CST.TypeDecl (wrap (CST.{kwd_type=rg; name; eq=rg; type_expr})) ok @@ CST.TypeDecl (wrap (CST.{kwd_type=rg; name; eq=rg; type_expr}))
| Declaration_constant (var, ty_opt, inline, expr) -> | Declaration_constant (var, ty_opt, inline, expr) ->
let attributes : CST.attributes = decompile_attributes inline in let attributes : CST.attributes = decompile_attributes inline in
let var = CST.PVar (decompile_variable var) in let var = CST.PVar (decompile_variable var.wrap_content) in
let binders = (var,[]) in let binders = (var,[]) in
match expr.expression_content with match expr.expression_content with
E_lambda lambda -> E_lambda lambda ->

View File

@ -282,14 +282,14 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
match param with match param with
ParamConst p -> ParamConst p ->
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
return (var, p_type) return (Location.wrap ?loc:(Some loc) @@ Var.of_name var, p_type)
| ParamVar p -> | ParamVar p ->
let (p, _) = r_split p in let (p, _) = r_split p in
let (var, _loc) = r_split p.var in let (var, loc) = r_split p.var in
let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in let%bind p_type = bind_map_option (compile_type_expression <@ snd) p.param_type in
return (var, p_type) return (Location.wrap ?loc:(Some loc) @@ Var.of_name var, p_type)
in in
let (func, loc) = r_split func in let (func, loc) = r_split func in
let (param, loc_par) = r_split func.param in let (param, loc_par) = r_split func.param in
@ -299,15 +299,15 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
let%bind body = compile_expression func.return in let%bind body = compile_expression func.return in
let (lambda, fun_type) = match param_type with let (lambda, fun_type) = match param_type with
ty::[] -> ty::[] ->
e_lambda ~loc (Var.of_name @@ List.hd param) ty ret_type body, e_lambda ~loc (List.hd param) ty ret_type body,
Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type) Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (ty,ret_type)
(* Cannot be empty *) (* Cannot be empty *)
| lst -> | lst ->
let lst = Option.bind_list lst in let lst = Option.bind_list lst in
let input_type = Option.map t_tuple lst in let input_type = Option.map t_tuple lst in
let binder = Var.fresh ~name:"parameter" () in let binder = Location.wrap ?loc:(Some loc_par) @@ Var.fresh ~name:"parameter" () in
e_lambda ~loc binder input_type (ret_type) @@ e_lambda ~loc binder input_type (ret_type) @@
e_matching_tuple_ez ~loc:loc_par (e_variable binder) param lst body, e_matching_tuple ~loc:loc_par (e_variable binder) param lst body,
Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type) Option.map (fun (a,b) -> t_function a b)@@ Option.bind_pair (input_type,ret_type)
in in
return @@ Option.unopt ~default:lambda @@ return @@ Option.unopt ~default:lambda @@
@ -443,7 +443,11 @@ fun compiler cases ->
tl::[] -> return (fst cons,tl) tl::[] -> return (fst cons,tl)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst cons | _ -> fail @@ unsupported_deep_list_patterns @@ fst cons
in in
let hd_loc = Location.lift @@ Raw.pattern_to_region hd in
let tl_loc = Location.lift @@ Raw.pattern_to_region hd in
let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in let%bind (hd,tl) = bind_map_pair compile_simple_pattern (hd,tl) in
let hd = Location.wrap ?loc:(Some hd_loc) hd in
let tl = Location.wrap ?loc:(Some tl_loc) tl in
let match_cons = (hd,tl,econs) in let match_cons = (hd,tl,econs) in
return (match_nil,match_cons) return (match_nil,match_cons)
| _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases | _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases
@ -460,21 +464,24 @@ fun compiler cases ->
( match c with ( match c with
PUnit _ -> PUnit _ ->
fail @@ unsupported_pattern_type constr fail @@ unsupported_pattern_type constr
| PFalse _ -> return (Constructor "false", Var.of_name "_") | PFalse _ -> return (Constructor "false", Location.wrap @@ Var.of_name "_")
| PTrue _ -> return (Constructor "true", Var.of_name "_") | PTrue _ -> return (Constructor "true", Location.wrap @@ Var.of_name "_")
| PNone _ -> return (Constructor "None", Var.of_name "_") | PNone _ -> return (Constructor "None", Location.wrap @@ Var.of_name "_")
| PSomeApp some -> | PSomeApp some ->
let (some,_) = r_split some in let (some,_) = r_split some in
let (_, pattern) = some in let (_, pattern) = some in
let (pattern,_) = r_split pattern in let (pattern,loc) = r_split pattern in
let%bind pattern = compile_simple_pattern pattern.inside in let%bind pattern = compile_simple_pattern pattern.inside in
return (Constructor "Some", pattern) return (Constructor "Some", Location.wrap ?loc:(Some loc) pattern)
| PConstrApp constr -> | PConstrApp constr ->
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let (constr, patterns) = constr in let (constr, patterns) = constr in
let (constr, _) = r_split constr in let (constr, _) = r_split constr in
let pattern_loc = match patterns with
| Some (v:CST.tuple_pattern) -> Location.lift v.region
| None -> Location.generated in
let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in let%bind pattern = bind_map_option compile_simple_tuple_pattern patterns in
let pattern = Option.unopt ~default:(Var.of_name "_") pattern in let pattern = Location.wrap ?loc:(Some pattern_loc) @@ Option.unopt ~default:(Var.of_name "_") pattern in
return (Constructor constr, pattern) return (Constructor constr, pattern)
) )
| _ -> fail @@ unsupported_pattern_type constr | _ -> fail @@ unsupported_pattern_type constr
@ -488,8 +495,8 @@ fun compiler cases ->
let%bind cases = bind_map_ne_list aux cases in let%bind cases = bind_map_ne_list aux cases in
match cases with match cases with
| (PVar var, expr), [] -> | (PVar var, expr), [] ->
let (var, _) = r_split var in let (var, loc) = r_split var in
let var = Var.of_name var in let var = Location.wrap ?loc:(Some loc) @@ Var.of_name var in
return @@ AST.Match_variable (var, None, expr) return @@ AST.Match_variable (var, None, expr)
| (PTuple tuple, _expr), [] -> | (PTuple tuple, _expr), [] ->
fail @@ unsupported_tuple_pattern @@ CST.PTuple tuple fail @@ unsupported_tuple_pattern @@ CST.PTuple tuple
@ -511,12 +518,14 @@ and compile_parameters (params : CST.parameters) =
match param with match param with
ParamConst pc -> ParamConst pc ->
let (pc, _loc) = r_split pc in let (pc, _loc) = r_split pc in
let (var, _) = r_split pc.var in let (var, loc) = r_split pc.var in
let var = Location.wrap ?loc:(Some loc) @@ Var.of_name var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pc.param_type in
return (var, param_type) return (var, param_type)
| ParamVar pv -> | ParamVar pv ->
let (pv, _loc) = r_split pv in let (pv, _loc) = r_split pv in
let (var, _) = r_split pv.var in let (var, loc) = r_split pv.var in
let var = Location.wrap ?loc:(Some loc) @@ Var.of_name var in
let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in let%bind param_type = bind_map_option (compile_type_expression <@ snd) pv.param_type in
return (var, param_type) return (var, param_type)
in in
@ -600,27 +609,32 @@ and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result
return @@ e_while ~loc cond body return @@ e_while ~loc cond body
| Loop (For (ForInt fl)) -> | Loop (For (ForInt fl)) ->
let (fl, loc) = r_split fl in let (fl, loc) = r_split fl in
let (binder, _) = r_split fl.binder in let (binder, binder_loc) = r_split fl.binder in
let%bind start = compile_expression fl.init in let%bind start = compile_expression fl.init in
let%bind bound = compile_expression fl.bound in let%bind bound = compile_expression fl.bound in
let%bind increment = Option.unopt ~default:(ok @@ e_int_z Z.one) @@ let%bind increment = Option.unopt ~default:(ok @@ e_int_z Z.one) @@
Option.map (compile_expression <@ snd) fl.step Option.map (compile_expression <@ snd) fl.step
in in
let%bind body = compile_block fl.block in let%bind body = compile_block fl.block in
return @@ e_for_ez ~loc binder start bound increment body return @@ e_for ~loc (Location.wrap ?loc:(Some binder_loc) @@ Var.of_name binder) start bound increment body
| Loop (For (ForCollect el)) -> | Loop (For (ForCollect el)) ->
let (el, loc) = r_split el in let (el, loc) = r_split el in
let binder = let binder =
let (key, _) = r_split el.var in let (key, loc) = r_split el.var in
let value = Option.map (fun x -> fst (r_split (snd x))) el.bind_to in let key' = Location.wrap ?loc:(Some loc) @@ Var.of_name key in
(key,value) let value = Option.map
(fun x ->
let (v,loc) = r_split (snd x) in
Location.wrap ?loc:(Some loc) @@ Var.of_name v)
el.bind_to in
(key',value)
in in
let%bind collection = compile_expression el.expr in let%bind collection = compile_expression el.expr in
let (collection_type, _) = match el.collection with let (collection_type, _) = match el.collection with
Map loc -> (Map, loc) | Set loc -> (Set, loc) | List loc -> (List, loc) Map loc -> (Map, loc) | Set loc -> (Set, loc) | List loc -> (List, loc)
in in
let%bind body = compile_block el.block in let%bind body = compile_block el.block in
return @@ e_for_each_ez ~loc binder collection collection_type body return @@ e_for_each ~loc binder collection collection_type body
| ProcCall {value=(EVar var,args);region} -> | ProcCall {value=(EVar var,args);region} ->
let loc = Location.lift region in let loc = Location.lift region in
let (var, loc_var) = r_split var in let (var, loc_var) = r_split var in
@ -696,20 +710,22 @@ and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result
and compile_data_declaration : next:AST.expression -> ?attr:CST.attr_decl -> CST.data_decl -> _ = fun ~next ?attr data_decl -> and compile_data_declaration : next:AST.expression -> ?attr:CST.attr_decl -> CST.data_decl -> _ = fun ~next ?attr data_decl ->
let return loc name type_ init = let return loc name type_ init =
let%bind attr = compile_attribute_declaration attr in let%bind attr = compile_attribute_declaration attr in
ok @@ e_let_in_ez ~loc name type_ attr init next in ok @@ e_let_in ~loc (name,type_) attr init next in
match data_decl with match data_decl with
LocalConst const_decl -> LocalConst const_decl ->
let (cd, loc) = r_split const_decl in let (cd, loc) = r_split const_decl in
let (name, _) = r_split cd.name in let (name, ploc) = r_split cd.name in
let%bind type_ = bind_map_option (compile_type_expression <@ snd)cd.const_type in let%bind type_ = bind_map_option (compile_type_expression <@ snd)cd.const_type in
let%bind init = compile_expression cd.init in let%bind init = compile_expression cd.init in
return loc name type_ init let p = Location.wrap ?loc:(Some ploc) @@ Var.of_name name in
return loc p type_ init
| LocalVar var_decl -> | LocalVar var_decl ->
let (vd, loc) = r_split var_decl in let (vd, loc) = r_split var_decl in
let (name, _) = r_split vd.name in let (name, ploc) = r_split vd.name in
let%bind type_ = bind_map_option (compile_type_expression <@ snd) vd.var_type in let%bind type_ = bind_map_option (compile_type_expression <@ snd) vd.var_type in
let%bind init = compile_expression vd.init in let%bind init = compile_expression vd.init in
return loc name type_ init let p = Location.wrap ?loc:(Some ploc) @@ Var.of_name name in
return loc p type_ init
| LocalFun fun_decl -> | LocalFun fun_decl ->
let (fun_decl,loc) = r_split fun_decl in let (fun_decl,loc) = r_split fun_decl in
let%bind (fun_name,fun_type,_attr,lambda) = compile_fun_decl fun_decl in let%bind (fun_name,fun_type,_attr,lambda) = compile_fun_decl fun_decl in
@ -741,6 +757,7 @@ and compile_block : ?next:AST.expression -> CST.block CST.reg -> _ result = fun
and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attributes}: CST.fun_decl) = and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attributes}: CST.fun_decl) =
let%bind attr = compile_attribute_declaration attributes in let%bind attr = compile_attribute_declaration attributes in
let (fun_name, loc) = r_split fun_name in let (fun_name, loc) = r_split fun_name in
let fun_binder = Location.wrap ?loc:(Some loc) @@ Var.of_name fun_name in
let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in let%bind ret_type = bind_map_option (compile_type_expression <@ snd) ret_type in
let%bind param = compile_parameters param in let%bind param = compile_parameters param in
let%bind result = compile_expression r in let%bind result = compile_expression r in
@ -749,7 +766,7 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attri
let (lambda,fun_type) = (match param_type with let (lambda,fun_type) = (match param_type with
ty::[] -> ty::[] ->
let lambda : AST.lambda = { let lambda : AST.lambda = {
binder = (Var.of_name @@ List.hd param); binder = List.hd param;
input_type = ty ; input_type = ty ;
output_type = ret_type ; output_type = ret_type ;
result; result;
@ -758,12 +775,12 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attri
| lst -> | lst ->
let lst = Option.bind_list lst in let lst = Option.bind_list lst in
let input_type = Option.map t_tuple lst in let input_type = Option.map t_tuple lst in
let binder = Var.fresh ~name:"parameters" () in let binder = Location.wrap @@ Var.fresh ~name:"parameters" () in
let lambda : AST.lambda = { let lambda : AST.lambda = {
binder; binder;
input_type = input_type; input_type = input_type;
output_type = ret_type; output_type = ret_type;
result = e_matching_tuple_ez (e_variable binder) param lst result; result = e_matching_tuple (e_variable binder) param lst result;
} in } in
lambda,Option.map (fun (a,b) -> t_function a b) @@ Option.bind_pair (input_type,ret_type) lambda,Option.map (fun (a,b) -> t_function a b) @@ Option.bind_pair (input_type,ret_type)
) )
@ -772,11 +789,11 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attri
let%bind func = match kwd_recursive with let%bind func = match kwd_recursive with
Some reg -> Some reg ->
let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in let%bind fun_type = trace_option (untyped_recursive_fun loc) @@ fun_type in
return @@ e_recursive_ez ~loc:(Location.lift reg) fun_name fun_type lambda return @@ e_recursive ~loc:(Location.lift reg) fun_binder fun_type lambda
| None -> | None ->
return @@ make_e ~loc @@ E_lambda lambda return @@ make_e ~loc @@ E_lambda lambda
in in
return (fun_name,fun_type, attr, func) return (fun_binder,fun_type, attr, func)
(* Currently attributes are badly proccess, some adaptation are made to accomodate this (* Currently attributes are badly proccess, some adaptation are made to accomodate this
maked as ATR *) maked as ATR *)
@ -790,16 +807,17 @@ let compile_declaration : (CST.attr_decl option * _) -> CST.declaration -> _ = f
let%bind type_expr = compile_type_expression type_expr in let%bind type_expr = compile_type_expression type_expr in
return region @@ AST.Declaration_type (Var.of_name name, type_expr) return region @@ AST.Declaration_type (Var.of_name name, type_expr)
| ConstDecl {value={name; const_type; init; attributes=_};region} -> | ConstDecl {value={name; const_type; init; attributes=_};region} ->
let (name, _) = r_split name in let (name, loc) = r_split name in
let name = Location.wrap ?loc:(Some loc) @@ Var.of_name name in
let attributes = attr in (*ATR*) let attributes = attr in (*ATR*)
let%bind const_type = bind_map_option (compile_type_expression <@ snd) const_type in let%bind const_type = bind_map_option (compile_type_expression <@ snd) const_type in
let%bind init = compile_expression init in let%bind init = compile_expression init in
let%bind attr = compile_attribute_declaration attributes in let%bind attr = compile_attribute_declaration attributes in
return region @@ AST.Declaration_constant (Var.of_name name, const_type,attr,init) return region @@ AST.Declaration_constant (name, const_type,attr,init)
| FunDecl {value;region} -> | FunDecl {value;region} ->
let value = {value with attributes = attr} in (*ATR*) let value = {value with attributes = attr} in (*ATR*)
let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in let%bind (fun_name,fun_type,attr,lambda) = compile_fun_decl value in
return region @@ AST.Declaration_constant (Var.of_name fun_name, fun_type, attr, lambda) return region @@ AST.Declaration_constant (fun_name, fun_type, attr, lambda)
| AttrDecl decl -> ok (Some decl, lst) (*ATR*) | AttrDecl decl -> ok (Some decl, lst) (*ATR*)
(* This should be change to the commented function when attributes are fixed (* This should be change to the commented function when attributes are fixed

View File

@ -99,7 +99,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let get_e_variable : AST.expression -> _ result = fun expr -> let get_e_variable : AST.expression -> _ result = fun expr ->
match expr.expression_content with match expr.expression_content with
E_variable var -> ok @@ var E_variable var -> ok @@ var.wrap_content
| _ -> failwith @@ | _ -> failwith @@
Format.asprintf "%a should be a variable expression" Format.asprintf "%a should be a variable expression"
AST.PP.expression expr AST.PP.expression expr
@ -186,7 +186,7 @@ and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)*
let return_inst inst = return_stat_ez @@ CST.Instr inst in let return_inst inst = return_stat_ez @@ CST.Instr inst in
match expr.expression_content with match expr.expression_content with
E_variable name -> E_variable name ->
let var = decompile_variable name in let var = decompile_variable name.wrap_content in
return_expr @@ CST.EVar (var) return_expr @@ CST.EVar (var)
| E_constant {cons_name; arguments} -> | E_constant {cons_name; arguments} ->
let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in let expr = CST.EVar (wrap @@ Predefined.constant_to_string cons_name) in
@ -255,7 +255,8 @@ and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)*
return_expr_with_par @@ CST.EFun (wrap @@ fun_expr) return_expr_with_par @@ CST.EFun (wrap @@ fun_expr)
| E_recursive _ -> | E_recursive _ ->
failwith "corner case : annonymous recursive function" failwith "corner case : annonymous recursive function"
| E_let_in {let_binder;rhs={expression_content=E_update {record={expression_content=E_variable var;_};path;update};_};let_result;inline=_} when Var.equal (fst let_binder) var -> | E_let_in {let_binder;rhs={expression_content=E_update {record={expression_content=E_variable var;_};path;update};_};let_result;inline=_}
when Var.equal (fst let_binder).wrap_content var.wrap_content ->
let%bind lhs = (match List.rev path with let%bind lhs = (match List.rev path with
Access_map e :: path -> Access_map e :: path ->
let%bind path = decompile_to_path var @@ List.rev path in let%bind path = decompile_to_path var @@ List.rev path in
@ -356,7 +357,7 @@ and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)*
Access_record var::path -> ok @@ (var,path) Access_record var::path -> ok @@ (var,path)
| _ -> failwith "Impossible case %a" | _ -> failwith "Impossible case %a"
in in
let%bind field_path = decompile_to_path (Var.of_name var) path in let%bind field_path = decompile_to_path (Location.wrap @@ Var.of_name var) path in
let%bind field_expr = decompile_expression update in let%bind field_expr = decompile_expression update in
let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in let field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} in
let updates = updates.value.ne_elements in let updates = updates.value.ne_elements in
@ -469,7 +470,7 @@ and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)*
let assign : CST.assignment = {lhs;assign=rg;rhs} in let assign : CST.assignment = {lhs;assign=rg;rhs} in
return_inst @@ Assign (wrap assign) return_inst @@ Assign (wrap assign)
| E_for {binder;start;final;increment;body} -> | E_for {binder;start;final;increment;body} ->
let binder = decompile_variable binder in let binder = decompile_variable binder.wrap_content in
let%bind init = decompile_expression start in let%bind init = decompile_expression start in
let%bind bound = decompile_expression final in let%bind bound = decompile_expression final in
let%bind step = decompile_expression increment in let%bind step = decompile_expression increment in
@ -479,8 +480,8 @@ and decompile_eos : eos -> AST.expression -> ((CST.statement List.Ne.t option)*
let fl : CST.for_int = {kwd_for=rg;binder;assign=rg;init;kwd_to=rg;bound;step;block} in let fl : CST.for_int = {kwd_for=rg;binder;assign=rg;init;kwd_to=rg;bound;step;block} in
return_inst @@ CST.Loop (For (ForInt (wrap fl))) return_inst @@ CST.Loop (For (ForInt (wrap fl)))
| E_for_each {binder;collection;collection_type;body} -> | E_for_each {binder;collection;collection_type;body} ->
let var = decompile_variable @@ fst binder in let var = decompile_variable @@ (fst binder).wrap_content in
let bind_to = Option.map (fun x -> (rg,decompile_variable x)) @@ snd binder in let bind_to = Option.map (fun (x:AST.expression_variable) -> (rg,decompile_variable x.wrap_content)) @@ snd binder in
let%bind expr = decompile_expression collection in let%bind expr = decompile_expression collection in
let collection = match collection_type with let collection = match collection_type with
Map -> CST.Map rg | Set -> Set rg | List -> List rg in Map -> CST.Map rg | Set -> Set rg | List -> List rg in
@ -505,7 +506,7 @@ and decompile_if_clause : AST.expression -> (CST.if_clause, _) result = fun e ->
ok @@ CST.ClauseBlock (ShortBlock (wrap @@ braces @@ clause)) ok @@ CST.ClauseBlock (ShortBlock (wrap @@ braces @@ clause))
and decompile_to_data_decl : (AST.expression_variable * AST.type_expression option) -> AST.expression -> bool -> (CST.data_decl, _) result = fun (name,ty_opt) expr inline -> and decompile_to_data_decl : (AST.expression_variable * AST.type_expression option) -> AST.expression -> bool -> (CST.data_decl, _) result = fun (name,ty_opt) expr inline ->
let name = decompile_variable name in let name = decompile_variable name.wrap_content in
let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in let%bind const_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) ty_opt in
let attributes : CST.attr_decl option = match inline with let attributes : CST.attr_decl option = match inline with
true -> Some (wrap @@ ne_inject (NEInjAttr rg) @@ (wrap @@ "inline",[])) true -> Some (wrap @@ ne_inject (NEInjAttr rg) @@ (wrap @@ "inline",[]))
@ -529,7 +530,7 @@ and decompile_to_data_decl : (AST.expression_variable * AST.type_expression opti
and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _) result = fun var access -> and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _) result = fun var access ->
match List.rev access with match List.rev access with
[] -> ok @@ (CST.Path (Name (decompile_variable var)) : CST.lhs) [] -> ok @@ (CST.Path (Name (decompile_variable var.wrap_content)) : CST.lhs)
| hd :: tl -> | hd :: tl ->
match hd with match hd with
| AST.Access_map e -> | AST.Access_map e ->
@ -542,7 +543,7 @@ and decompile_to_lhs : AST.expression_variable -> AST.access list -> (CST.lhs, _
ok @@ (CST.Path (path) : CST.lhs) ok @@ (CST.Path (path) : CST.lhs)
and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access -> and decompile_to_path : AST.expression_variable -> AST.access list -> (CST.path, _) result = fun var access ->
let struct_name = decompile_variable var in let struct_name = decompile_variable var.wrap_content in
match access with match access with
[] -> ok @@ CST.Name struct_name [] -> ok @@ CST.Name struct_name
| lst -> | lst ->
@ -559,7 +560,7 @@ and decompile_to_selection : AST.access -> (CST.selection, _) result = fun acces
"Can't decompile access_map to selection" "Can't decompile access_map to selection"
and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} -> and decompile_lambda : AST.lambda -> _ = fun {binder;input_type;output_type;result} ->
let var = decompile_variable binder in let var = decompile_variable binder.wrap_content in
let%bind param_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) input_type in let%bind param_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) input_type in
let param_const : CST.param_const = {kwd_const=rg;var;param_type} in let param_const : CST.param_const = {kwd_const=rg;var;param_type} in
let param_decl : CST.param_decl = ParamConst (wrap param_const) in let param_decl : CST.param_decl = ParamConst (wrap param_const) in
@ -573,12 +574,12 @@ and decompile_matching_expr : type a.(AST.expr ->(a,_) result) -> AST.matching_e
fun f m -> fun f m ->
let%bind cases = match m with let%bind cases = match m with
Match_variable (var, _ty_opt, expr) -> Match_variable (var, _ty_opt, expr) ->
let pattern : CST.pattern = PVar (decompile_variable var) in let pattern : CST.pattern = PVar (decompile_variable var.wrap_content) in
let%bind rhs = f expr in let%bind rhs = f expr in
let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in let case : _ CST.case_clause = {pattern; arrow=rg; rhs}in
ok @@ [wrap case] ok @@ [wrap case]
| Match_tuple (lst, _ty_opt, expr) -> | Match_tuple (lst, _ty_opt, expr) ->
let aux var = CST.PVar (decompile_variable var) in let aux (var:AST.expression_variable) = CST.PVar (decompile_variable var.wrap_content) in
let%bind tuple = list_to_nsepseq @@ List.map aux lst in let%bind tuple = list_to_nsepseq @@ List.map aux lst in
let pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in let pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in
let%bind rhs = f expr in let%bind rhs = f expr in
@ -589,13 +590,13 @@ fun f m ->
let%bind rhs = f match_none in let%bind rhs = f match_none in
let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} in
let%bind rhs = f @@ snd match_some in let%bind rhs = f @@ snd match_some in
let var = wrap @@ par @@ CST.PVar (decompile_variable @@ fst match_some)in let var = wrap @@ par @@ CST.PVar (decompile_variable @@ (fst match_some).wrap_content)in
let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in let some_case : _ CST.case_clause = {pattern=PConstr (PSomeApp (wrap (rg,var)));arrow=rg; rhs} in
ok @@ [wrap some_case;wrap none_case] ok @@ [wrap some_case;wrap none_case]
| Match_list {match_nil; match_cons} -> | Match_list {match_nil; match_cons} ->
let (hd,tl,expr) = match_cons in let (hd,tl,expr) = match_cons in
let hd = CST.PVar (decompile_variable hd) in let hd = CST.PVar (decompile_variable hd.wrap_content) in
let tl = CST.PVar (decompile_variable tl) in let tl = CST.PVar (decompile_variable tl.wrap_content) in
let cons = (hd,[rg,tl]) in let cons = (hd,[rg,tl]) in
let%bind rhs = f @@ expr in let%bind rhs = f @@ expr in
let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in let cons_case : _ CST.case_clause = {pattern=PList (PCons (wrap cons));arrow=rg; rhs} in
@ -603,10 +604,10 @@ fun f m ->
let nil_case : _ CST.case_clause = {pattern=PList (PNil rg);arrow=rg; rhs} in let nil_case : _ CST.case_clause = {pattern=PList (PNil rg);arrow=rg; rhs} in
ok @@ [wrap cons_case; wrap nil_case] ok @@ [wrap cons_case; wrap nil_case]
| Match_variant lst -> | Match_variant lst ->
let aux ((c,v),e) = let aux ((c,(v:AST.expression_variable)),e) =
let AST.Constructor c = c in let AST.Constructor c = c in
let constr = wrap @@ c in let constr = wrap @@ c in
let var : CST.pattern = PVar (decompile_variable v) in let var : CST.pattern = PVar (decompile_variable v.wrap_content) in
let tuple = wrap @@ par @@ (var,[]) in let tuple = wrap @@ par @@ (var,[]) in
let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in let pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in
let%bind rhs = f e in let%bind rhs = f e in
@ -637,7 +638,7 @@ let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _
Some attr_decl Some attr_decl
| false -> None | false -> None
in in
let name = decompile_variable var in let name = decompile_variable var.wrap_content in
let fun_name = name in let fun_name = name in
match expr.expression_content with match expr.expression_content with
E_lambda lambda -> E_lambda lambda ->

View File

@ -3,6 +3,8 @@ module I = Ast_imperative
module O = Ast_sugar module O = Ast_sugar
open Trace open Trace
let compare_var = Location.compare_content ~compare:Var.compare
let rec add_to_end (expression: O.expression) to_add = let rec add_to_end (expression: O.expression) to_add =
match expression.expression_content with match expression.expression_content with
| O.E_let_in lt -> | O.E_let_in lt ->
@ -23,11 +25,11 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam
ok (true,(name::decl_var, free_var),O.e_let_in let_binder false false rhs let_result) ok (true,(name::decl_var, free_var),O.e_let_in let_binder false false rhs let_result)
| E_let_in {let_binder;mut=true; rhs;let_result} -> | E_let_in {let_binder;mut=true; rhs;let_result} ->
let (name,_) = let_binder in let (name,_) = let_binder in
if List.mem name decl_var then if List.mem ~compare:compare_var name decl_var then
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 ~compare:compare_var 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) [O.Access_record (Var.to_name name)] (O.e_variable name)) let_result in let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) [O.Access_record (Var.to_name name.wrap_content)] (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= _}
@ -63,12 +65,15 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names :
ok (true,(name::decl_var, free_var),ass_exp) ok (true,(name::decl_var, free_var),ass_exp)
| E_let_in {let_binder;mut=true; rhs;let_result} -> | E_let_in {let_binder;mut=true; rhs;let_result} ->
let (name,_) = let_binder in let (name,_) = let_binder in
if List.mem name decl_var then if List.mem ~compare:compare_var name decl_var then
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 ~compare:compare_var 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) [O.Access_tuple Z.zero; O.Access_record (Var.to_name name)] (O.e_variable name) O.e_update (O.e_variable env) [O.Access_tuple Z.zero; O.Access_record (Var.to_name name.wrap_content)] (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,12 +100,12 @@ and store_mutable_variable (free_vars : I.expression_variable list) =
if (List.length free_vars == 0) then if (List.length free_vars == 0) then
O.e_unit () O.e_unit ()
else else
let aux var = (O.Label (Var.to_name var), O.e_variable var) in let aux (var:I.expression_variable) = (O.Label (Var.to_name var.wrap_content), O.e_variable var) in
O.e_record @@ O.LMap.of_list (List.map aux free_vars) O.e_record @@ O.LMap.of_list (List.map aux free_vars)
and restore_mutable_variable (expr : O.expression->O.expression) (free_vars : O.expression_variable list) (env : O.expression_variable) = and restore_mutable_variable (expr : O.expression->O.expression) (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) [O.Access_record (Var.to_name ev)]) expr) fun expr -> f (O.e_let_in (ev,None) true false (O.e_accessor (O.e_variable env) [O.Access_record (Var.to_name ev.wrap_content)]) 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
fun e -> match e with fun e -> match e with
@ -252,13 +257,13 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression,
let%bind condition = compile_expression condition in let%bind condition = compile_expression condition in
let%bind then_clause' = compile_expression then_clause in let%bind then_clause' = compile_expression then_clause in
let%bind else_clause' = compile_expression else_clause in let%bind else_clause' = compile_expression else_clause in
let env = Var.fresh ~name:"env" () in let env = Location.wrap (Var.fresh ~name:"env" ()) in
let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in
let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in
let then_clause = add_to_end then_clause (O.e_variable env) in let then_clause = add_to_end then_clause (O.e_variable env) in
let else_clause = add_to_end else_clause (O.e_variable env) in let else_clause = add_to_end else_clause (O.e_variable env) in
let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in let free_vars = List.sort_uniq compare_var @@ free_vars_true @ free_vars_false in
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let cond_expr = O.e_cond condition then_clause else_clause in let cond_expr = O.e_cond condition then_clause else_clause in
let return_expr = fun expr -> let return_expr = fun expr ->
@ -330,12 +335,12 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let%bind match_none' = compile_expression match_none in let%bind match_none' = compile_expression match_none in
let (n,expr) = match_some in let (n,expr) = match_some in
let%bind expr' = compile_expression expr in let%bind expr' = compile_expression expr in
let env = Var.fresh ~name:"env" () in let env = Location.wrap (Var.fresh ~name:"env" ()) in
let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in let%bind ((_,free_vars_none), match_none) = repair_mutable_variable_in_matching match_none' [] env in
let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in let%bind ((_,free_vars_some), expr) = repair_mutable_variable_in_matching expr' [n] env in
let match_none = add_to_end match_none (O.e_variable env) in let match_none = add_to_end match_none (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_none @ free_vars_some in let free_vars = List.sort_uniq compare_var @@ free_vars_none @ free_vars_some in
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in
let return_expr = fun expr -> let return_expr = fun expr ->
@ -350,12 +355,12 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let%bind match_nil' = compile_expression match_nil in let%bind match_nil' = compile_expression match_nil in
let (hd,tl,expr) = match_cons in let (hd,tl,expr) = match_cons in
let%bind expr' = compile_expression expr in let%bind expr' = compile_expression expr in
let env = Var.fresh ~name:"name" () in let env = Location.wrap (Var.fresh ~name:"name" ()) in
let%bind ((_,free_vars_nil), match_nil) = repair_mutable_variable_in_matching match_nil' [] env 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%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 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 let free_vars = List.sort_uniq compare_var @@ free_vars_nil @ free_vars_cons in
if (List.length free_vars != 0) then if (List.length free_vars != 0) then
let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in
let return_expr = fun expr -> let return_expr = fun expr ->
@ -367,7 +372,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
else else
return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')} return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')}
| I.Match_variant lst -> | I.Match_variant lst ->
let env = Var.fresh ~name:"env" () in let env = Location.wrap (Var.fresh ~name:"env" ()) in
let aux fv ((c,n),expr) = let aux fv ((c,n),expr) =
let%bind expr = compile_expression expr in let%bind expr = compile_expression expr in
let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in let%bind ((_,free_vars), case_clause) = repair_mutable_variable_in_matching expr [n] env in
@ -375,7 +380,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
let case_clause = add_to_end case_clause (O.e_variable env) in let case_clause = add_to_end case_clause (O.e_variable env) in
ok (free_vars::fv,((c,n), case_clause, case_clause')) in ok (free_vars::fv,((c,n), case_clause, case_clause')) in
let%bind (fv,cases) = bind_fold_map_list aux [] lst in let%bind (fv,cases) = bind_fold_map_list aux [] lst in
let free_vars = List.sort_uniq Var.compare @@ List.concat fv in let free_vars = List.sort_uniq compare_var @@ List.concat fv in
if (List.length free_vars == 0) then ( if (List.length free_vars == 0) then (
let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in 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 return @@ O.e_matching ~loc matchee @@ O.Match_variant cases
@ -403,8 +408,8 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp
return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr) return @@ O.e_matching ~loc matchee @@ O.Match_variable (lst,ty_opt,expr)
and compile_while I.{condition;body} = and compile_while I.{condition;body} =
let env_rec = Var.fresh ~name:"env_rec" () in let env_rec = Location.wrap @@ Var.fresh ~name:"env_rec" () in
let binder = Var.fresh ~name:"binder" () in let binder = Location.wrap @@ Var.fresh ~name:"binder" () in
let%bind cond = compile_expression condition in let%bind cond = compile_expression condition in
let ctrl = let ctrl =
@ -416,7 +421,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_variable binder) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable binder) [Access_tuple Z.zero; Access_record (Var.to_name name.wrap_content)]) 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
@ -438,7 +443,7 @@ and compile_while I.{condition;body} =
and compile_for I.{binder;start;final;increment;body} = and compile_for I.{binder;start;final;increment;body} =
let env_rec = Var.fresh ~name:"env_rec" () in let env_rec = Location.wrap @@ Var.fresh ~name:"env_rec" () in
(*Make the cond and the step *) (*Make the cond and the step *)
let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) (I.t_bool ()) in let cond = I.e_annotation (I.e_constant C_LE [I.e_variable binder ; final]) (I.t_bool ()) in
let%bind cond = compile_expression cond in let%bind cond = compile_expression cond in
@ -455,7 +460,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_variable env_rec) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable env_rec) [Access_tuple Z.zero; Access_record (Var.to_name name.wrap_content)]) expr
in in
(* restores the initial value of the free_var*) (* restores the initial value of the free_var*)
@ -483,8 +488,8 @@ and compile_for I.{binder;start;final;increment;body} =
ok @@ restore_mutable_variable return_expr captured_name_list env_rec ok @@ restore_mutable_variable return_expr captured_name_list env_rec
and compile_for_each I.{binder;collection;collection_type; body} = and compile_for_each I.{binder;collection;collection_type; body} =
let env_rec = Var.fresh ~name:"env_rec" () in let env_rec = Location.wrap @@ Var.fresh ~name:"env_rec" () in
let args = Var.fresh ~name:"args" () in let args = Location.wrap @@ Var.fresh ~name:"args" () in
let%bind element_names = ok @@ match snd binder with let%bind element_names = ok @@ match snd binder with
| Some v -> [fst binder;v] | Some v -> [fst binder;v]
@ -498,7 +503,7 @@ and compile_for_each I.{binder;collection;collection_type; body} =
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_variable args) [Access_tuple Z.zero; Access_record (Var.to_name name)]) expr O.e_let_in (name,None) false false (O.e_accessor (O.e_variable args) [Access_tuple Z.zero; Access_record (Var.to_name name.wrap_content)]) 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

View File

@ -171,11 +171,12 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
let%bind matchee = compile_expression condition in let%bind matchee = compile_expression condition in
let%bind match_true = compile_expression then_clause in let%bind match_true = compile_expression then_clause in
let%bind match_false = compile_expression else_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)])} let muted = Location.wrap @@ Var.of_name "_" in
return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", muted), match_true);((Constructor "false", muted), match_false)])}
| 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
return @@ O.E_let_in {let_binder=(Var.of_name "_", Some (O.t_unit ())); rhs=expr1;let_result=expr2; inline=false} return @@ O.E_let_in {let_binder=(Location.wrap @@ Var.of_name "_", Some (O.t_unit ())); rhs=expr1;let_result=expr2; inline=false}
| I.E_skip -> ok @@ O.e_unit ~loc:sugar.location ~sugar () | I.E_skip -> ok @@ O.e_unit ~loc:sugar.location ~sugar ()
| I.E_tuple t -> | I.E_tuple t ->
let aux (i,acc) el = let aux (i,acc) el =

View File

@ -66,7 +66,9 @@ let rec decompile_expression : O.expression -> (I.expression, desugaring_error)
let%bind fun_type = decompile_type_expression fun_type in let%bind fun_type = decompile_type_expression fun_type in
let%bind lambda = decompile_lambda lambda in let%bind lambda = decompile_lambda lambda in
return @@ I.E_recursive {fun_name;fun_type;lambda} return @@ I.E_recursive {fun_name;fun_type;lambda}
| O.E_let_in {let_binder;inline=false;rhs=expr1;let_result=expr2} when let_binder = (Var.of_name "_", Some (O.t_unit ())) -> | O.E_let_in {let_binder = (var, ty);inline=false;rhs=expr1;let_result=expr2}
when Var.equal var.wrap_content (Var.of_name "_")
&& Pervasives.(=) ty (Some (O.t_unit ())) ->
let%bind expr1 = decompile_expression expr1 in let%bind expr1 = decompile_expression expr1 in
let%bind expr2 = decompile_expression expr2 in let%bind expr2 = decompile_expression expr2 in
return @@ I.E_sequence {expr1;expr2} return @@ I.E_sequence {expr1;expr2}

View File

@ -743,7 +743,7 @@ and type_lambda e {
match result.content with match result.content with
| I.E_let_in li -> ( | I.E_let_in li -> (
match li.rhs.content with match li.rhs.content with
| I.E_variable name when name = (binder) -> ( | I.E_variable name when Location.equal_content ~equal:Var.equal name binder -> (
match snd li.let_binder with match snd li.let_binder with
| Some ty -> ok ty | Some ty -> ok ty
| None -> default_action li.rhs () | None -> default_action li.rhs ()

View File

@ -256,7 +256,7 @@ type contract_type = {
let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program -> let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
let aux declt = match Location.unwrap declt with let aux declt = match Location.unwrap declt with
| Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) -> | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
if Var.equal binder @@ Var.of_name main_fname if Var.equal binder.wrap_content (Var.of_name main_fname)
then Some p then Some p
else None else None
| Declaration_type _ -> None | Declaration_type _ -> None

View File

@ -23,7 +23,7 @@ let constructor (constructor:constructor') (element:expression) (t:type_expressi
} }
let match_var (t:type_expression) = let match_var (t:type_expression) =
{ expression_content = E_variable (Var.of_name "x") ; { expression_content = E_variable (Location.wrap @@ Var.of_name "x") ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
} }
@ -151,20 +151,20 @@ let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bod
| [m] , bl::br::[] -> | [m] , bl::br::[] ->
let cases = [ let cases = [
{ constructor = Constructor "M_left" ; { constructor = Constructor "M_left" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = bl } ; body = bl } ;
{ constructor = Constructor "M_right" ; { constructor = Constructor "M_right" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = br } ] in body = br } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| m::mtl , b::btl -> | m::mtl , b::btl ->
let%bind body = from_right_comb_or to_convert e (mtl,btl) in let%bind body = from_right_comb_or to_convert e (mtl,btl) in
let cases = [ let cases = [
{ constructor = Constructor "M_left" ; { constructor = Constructor "M_left" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = b } ; body = b } ;
{ constructor = Constructor "M_right" ; { constructor = Constructor "M_right" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body } ] in body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| _ -> fail @@ corner_case "from_right_comb conversion" | _ -> fail @@ corner_case "from_right_comb conversion"
@ -174,20 +174,20 @@ let rec from_left_comb_or (to_convert:expression) (e:expression) (matchee_t,bodi
| [m] , bl::br::[] -> | [m] , bl::br::[] ->
let cases = [ let cases = [
{ constructor = Constructor "M_right" ; { constructor = Constructor "M_right" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = bl } ; body = bl } ;
{ constructor = Constructor "M_left" ; { constructor = Constructor "M_left" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = br } ] in body = br } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| m::mtl , b::btl -> | m::mtl , b::btl ->
let%bind body = from_left_comb_or to_convert e (mtl,btl) in let%bind body = from_left_comb_or to_convert e (mtl,btl) in
let cases = [ let cases = [
{ constructor = Constructor "M_right" ; { constructor = Constructor "M_right" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body = b } ; body = b } ;
{ constructor = Constructor "M_left" ; { constructor = Constructor "M_left" ;
pattern = Var.of_name "x"; pattern = Location.wrap @@ Var.of_name "x";
body } ] in body } ] in
ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression })
| _ -> fail @@ corner_case "from_left_comb conversion" | _ -> fail @@ corner_case "from_left_comb conversion"
@ -210,7 +210,7 @@ let peephole_expression : expression -> (expression , self_ast_typed_error) resu
let src_kvl = to_sorted_kv_list_c src_cmap in let src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = left_comb_variant_combination e dst_cmap src_kvl in let bodies = left_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) = let to_cases ((constructor,{ctor_type=_;_}),body) =
let pattern = (Var.of_name "x") in let pattern = Location.wrap @@ Var.of_name "x" in
{constructor ; pattern ; body } {constructor ; pattern ; body }
in in
let cases = Match_variant { let cases = Match_variant {
@ -230,7 +230,7 @@ let peephole_expression : expression -> (expression , self_ast_typed_error) resu
let src_kvl = to_sorted_kv_list_c src_cmap in let src_kvl = to_sorted_kv_list_c src_cmap in
let bodies = right_comb_variant_combination e dst_cmap src_kvl in let bodies = right_comb_variant_combination e dst_cmap src_kvl in
let to_cases ((constructor,{ctor_type=_;_}),body) = let to_cases ((constructor,{ctor_type=_;_}),body) =
let pattern = (Var.of_name "x") in let pattern = Location.wrap @@ Var.of_name "x" in
{constructor ; pattern ; body } {constructor ; pattern ; body }
in in
let cases = Match_variant { let cases = Match_variant {

View File

@ -2,6 +2,8 @@ open Errors
open Ast_typed open Ast_typed
open Trace open Trace
let var_equal = Location.equal_content ~equal:Var.equal
let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e -> let rec check_recursive_call : expression_variable -> bool -> expression -> (unit, self_ast_typed_error) result = fun n final_path e ->
match e.expression_content with match e.expression_content with
| E_literal _ -> ok () | E_literal _ -> ok ()
@ -10,7 +12,7 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> (uni
ok () ok ()
| E_variable v -> ( | E_variable v -> (
let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location) let%bind _ = Assert.assert_true (recursive_call_is_only_allowed_as_the_last_operation n e.location)
(final_path || n <> v) in (final_path || not (var_equal n v)) in
ok () ok ()
) )
| E_application {lamb;args} -> | E_application {lamb;args} ->

View File

@ -380,7 +380,7 @@ let eval : Ast_typed.program -> (string , _) result =
ok (V_Failure s) ok (V_Failure s)
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
in in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) in let pp' = pp^"\n val "^(Var.to_name binder.wrap_content)^" = "^(Ligo_interpreter.PP.pp_value v) in
let top_env' = Env.extend top_env (binder, v) in let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env') ok @@ (pp',top_env')
| Ast_typed.Declaration_type _ -> | Ast_typed.Declaration_type _ ->

View File

@ -406,7 +406,7 @@ and compile_expression (ae:AST.expression) : (expression , spilling_error) resul
let%bind f' = compile_expression f in let%bind f' = compile_expression f in
let%bind input' = compile_type input in let%bind input' = compile_type input in
let%bind output' = compile_type output in let%bind output' = compile_type output in
let binder = Var.fresh ~name:"iterated" () in let binder = Location.wrap @@ Var.fresh ~name:"iterated" () in
let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in let application = Mini_c.Combinators.e_application f' output' (Mini_c.Combinators.e_var binder input') in
ok ((binder , input'), application) ok ((binder , input'), application)
in in
@ -507,13 +507,13 @@ and compile_expression (ae:AST.expression) : (expression , spilling_error) resul
| ((`Node (a , b)) , tv) -> | ((`Node (a , b)) , tv) ->
let%bind a' = let%bind a' =
let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in
let left_var = Var.fresh ~name:"left" () in let left_var = Location.wrap @@ Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e) ok ((left_var , a_ty) , e)
in in
let%bind b' = let%bind b' =
let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in
let right_var = Var.fresh ~name:"right" () in let right_var = Location.wrap @@ Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e) ok ((right_var , b_ty) , e)
in in
@ -558,7 +558,7 @@ and compile_recursive {fun_name; fun_type; lambda} =
and replace_callback : AST.expression_variable -> type_expression -> bool -> AST.expression -> (expression , spilling_error) result = fun fun_name loop_type shadowed e -> and replace_callback : AST.expression_variable -> type_expression -> bool -> AST.expression -> (expression , spilling_error) result = fun fun_name loop_type shadowed e ->
match e.expression_content with match e.expression_content with
E_let_in li -> E_let_in li ->
let shadowed = shadowed || Var.equal li.let_binder fun_name in let shadowed = shadowed || Var.equal li.let_binder.wrap_content fun_name.wrap_content in
let%bind let_result = replace_callback fun_name loop_type shadowed li.let_result in let%bind let_result = replace_callback fun_name loop_type shadowed li.let_result in
let%bind rhs = compile_expression li.rhs in let%bind rhs = compile_expression li.rhs in
let%bind ty = compile_type e.type_expression in let%bind ty = compile_type e.type_expression in
@ -568,7 +568,7 @@ and compile_recursive {fun_name; fun_type; lambda} =
matching fun_name loop_type shadowed m ty | matching fun_name loop_type shadowed m ty |
E_application {lamb;args} -> ( E_application {lamb;args} -> (
match lamb.expression_content,shadowed with match lamb.expression_content,shadowed with
E_variable name, false when Var.equal fun_name name -> E_variable name, false when Var.equal fun_name.wrap_content name.wrap_content ->
let%bind expr = compile_expression args in let%bind expr = compile_expression args in
ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type | ok @@ Expression.make (E_constant {cons_name=C_LOOP_CONTINUE;arguments=[expr]}) loop_type |
_ -> _ ->
@ -641,13 +641,13 @@ and compile_recursive {fun_name; fun_type; lambda} =
| ((`Node (a , b)) , tv) -> | ((`Node (a , b)) , tv) ->
let%bind a' = let%bind a' =
let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in let%bind a_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_left tv in
let left_var = Var.fresh ~name:"left" () in let left_var = Location.wrap @@ Var.fresh ~name:"left" () in
let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in let%bind e = aux (((Expression.make (E_variable left_var) a_ty))) a in
ok ((left_var , a_ty) , e) ok ((left_var , a_ty) , e)
in in
let%bind b' = let%bind b' =
let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in let%bind b_ty = trace_option (corner_case ~loc:__LOC__ "wrongtype") @@ get_t_right tv in
let right_var = Var.fresh ~name:"right" () in let right_var = Location.wrap @@ Var.fresh ~name:"right" () in
let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in let%bind e = aux (((Expression.make (E_variable right_var) b_ty))) b in
ok ((right_var , b_ty) , e) ok ((right_var , b_ty) , e)
in in

View File

@ -181,7 +181,7 @@ let eta : bool ref -> expression -> expression =
{ content = E_constant {cons_name = C_CDR; arguments = [ e2 ]} ; type_expression = _ }]} -> { content = E_constant {cons_name = C_CDR; arguments = [ e2 ]} ; type_expression = _ }]} ->
(match (e1.content, e2.content) with (match (e1.content, e2.content) with
| E_variable x1, E_variable x2 -> | E_variable x1, E_variable x2 ->
if Var.equal x1 x2 if Var.equal x1.wrap_content x2.wrap_content
then then
(changed := true; (changed := true;
{ e with content = e1.content }) { e with content = e1.content })

View File

@ -20,8 +20,8 @@ let rec replace : expression -> var_name -> var_name -> expression =
fun e x y -> fun e x y ->
let replace e = replace e x y in let replace e = replace e x y in
let return content = { e with content } in let return content = { e with content } in
let replace_var v = let replace_var (v:var_name) =
if Var.equal v x if Var.equal v.wrap_content x.wrap_content
then y then y
else v in else v in
match e.content with match e.content with
@ -103,16 +103,16 @@ let rec replace : expression -> var_name -> var_name -> expression =
let rec subst_expression : body:expression -> x:var_name -> expr:expression -> expression = let rec subst_expression : body:expression -> x:var_name -> expr:expression -> expression =
fun ~body ~x ~expr -> fun ~body ~x ~expr ->
let self body = subst_expression ~body ~x ~expr in let self body = subst_expression ~body ~x ~expr in
let subst_binder y expr' = let subst_binder (y:var_name) expr' =
(* if x is shadowed, binder doesn't change *) (* if x is shadowed, binder doesn't change *)
if Var.equal x y if Var.equal x.wrap_content y.wrap_content
then (y, expr') then (y, expr')
(* else, if no capture, subst in binder *) (* else, if no capture, subst in binder *)
else if not (Free_variables.mem y (Free_variables.expression [] expr)) else if not (Free_variables.mem y (Free_variables.expression [] expr))
then (y, self expr') then (y, self expr')
(* else, avoid capture and subst in binder *) (* else, avoid capture and subst in binder *)
else else
let fresh = Var.fresh_like y in let fresh = Location.wrap @@ Var.fresh_like y.wrap_content in
let new_body = replace expr' y fresh in let new_body = replace expr' y fresh in
(fresh, self new_body) in (fresh, self new_body) in
(* hack to avoid reimplementing subst_binder for 2-ary binder in E_if_cons: (* hack to avoid reimplementing subst_binder for 2-ary binder in E_if_cons:
@ -128,7 +128,7 @@ let rec subst_expression : body:expression -> x:var_name -> expr:expression -> e
let return_id = body in let return_id = body in
match body.content with match body.content with
| E_variable x' -> | E_variable x' ->
if x' = x if Location.equal_content ~equal:Var.equal x' x
then expr then expr
else return_id else return_id
| E_closure { binder; body } -> ( | E_closure { binder; body } -> (
@ -202,16 +202,16 @@ let%expect_test _ =
let dummy_type = Expression.make_t @@ T_base TB_unit in let dummy_type = Expression.make_t @@ T_base TB_unit in
let wrap e = Expression.make e dummy_type in let wrap e = Expression.make e dummy_type in
let show_subst ~body ~x ~expr = let show_subst ~body ~(x:var_name) ~expr =
Format.printf "(%a)[%a := %a] =@ %a" Format.printf "(%a)[%a := %a] =@ %a"
PP.expression body PP.expression body
Var.pp x Var.pp x.wrap_content
PP.expression expr PP.expression expr
PP.expression (subst_expression ~body ~x ~expr) in PP.expression (subst_expression ~body ~x ~expr) in
let x = Var.of_name "x" in let x = Location.wrap @@ Var.of_name "x" in
let y = Var.of_name "y" in let y = Location.wrap @@ Var.of_name "y" in
let z = Var.of_name "z" in let z = Location.wrap @@ Var.of_name "z" in
let var x = wrap (E_variable x) in let var x = wrap (E_variable x) in
let app f x = wrap (E_application (f, x)) in let app f x = wrap (E_application (f, x)) in
@ -411,7 +411,7 @@ let%expect_test _ =
(* old bug *) (* old bug *)
Var.reset_counter () ; Var.reset_counter () ;
let y0 = Var.fresh ~name:"y" () in let y0 = Location.wrap @@ Var.fresh ~name:"y" () in
show_subst show_subst
~body:(lam y (lam y0 (app (var x) (app (var y) (var y0))))) ~body:(lam y (lam y0 (app (var x) (app (var y) (var y0)))))
~x:x ~x:x

View File

@ -31,8 +31,9 @@ let pack_closure : environment -> selector -> (michelson, stacking_error) result
let e_lst = let e_lst =
let e_lst = Environment.to_list e in let e_lst = Environment.to_list e in
let aux selector (s , _) = let aux selector (s , _) =
match List.mem ~compare:Var.compare s selector with let var_compare = fun (a:var_name) (b:var_name) -> Var.compare a.wrap_content b.wrap_content in
| true -> List.remove_element ~compare:Var.compare s selector , true match List.mem ~compare:var_compare s selector with
| true -> List.remove_element ~compare:var_compare s selector , true
| false -> selector , false in | false -> selector , false in
let e_lst' = List.fold_map_right aux lst e_lst in let e_lst' = List.fold_map_right aux lst e_lst in
let e_lst'' = List.combine e_lst e_lst' in let e_lst'' = List.combine e_lst e_lst' in

View File

@ -226,7 +226,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac
) )
| E_application (f , arg) -> ( | E_application (f , arg) -> (
trace_strong (corner_case ~loc:__LOC__ "Compiling quote application") @@ trace_strong (corner_case ~loc:__LOC__ "Compiling quote application") @@
let%bind f = translate_expression f (Environment.add (Var.fresh (), arg.type_expression) env) in let%bind f = translate_expression f (Environment.add (Location.wrap @@ Var.fresh (), arg.type_expression) env) in
let%bind arg = translate_expression arg env in let%bind arg = translate_expression arg env in
return @@ seq [ return @@ seq [
arg ; arg ;
@ -256,7 +256,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac
PP.expression expr PP.expression expr
Michelson.pp expr_code Michelson.pp expr_code
PP.environment env ; PP.environment env ;
let env = Environment.add (Var.fresh (), expr.type_expression) env in let env = Environment.add (Location.wrap @@ Var.fresh (), expr.type_expression) env in
let code = code @ [expr_code] in let code = code @ [expr_code] in
ok (code, env) in ok (code, env) in
bind_fold_right_list aux ([], env) lst in bind_fold_right_list aux ([], env) lst in
@ -401,7 +401,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac
let%bind collection' = let%bind collection' =
translate_expression translate_expression
collection collection
(Environment.add (Var.fresh (), initial.type_expression) env) in (Environment.add (Location.wrap @@ Var.fresh (), initial.type_expression) env) in
let%bind initial' = translate_expression initial env in let%bind initial' = translate_expression initial env in
let%bind body' = translate_expression body (Environment.add v env) in let%bind body' = translate_expression body (Environment.add v env) in
let code = seq [ let code = seq [
@ -417,7 +417,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac
| E_record_update (record, path, expr) -> ( | E_record_update (record, path, expr) -> (
let%bind record' = translate_expression record env in let%bind record' = translate_expression record env in
let record_var = Var.fresh () in let record_var = Location.wrap @@ Var.fresh () in
let env' = Environment.add (record_var, record.type_expression) env in let env' = Environment.add (record_var, record.type_expression) env in
let%bind expr' = translate_expression expr env' in let%bind expr' = translate_expression expr env' in
let modify_code = let modify_code =

View File

@ -46,7 +46,7 @@ let rec error_ppformat : display_format:string display_format ->
match a with match a with
| `Stacking_get_environment (var,env) -> | `Stacking_get_environment (var,env) ->
let s = Format.asprintf "failed to get var %a in environment %a" let s = Format.asprintf "failed to get var %a in environment %a"
Var.pp var Var.pp var.wrap_content
Mini_c.PP.environment env in Mini_c.PP.environment env in
Format.pp_print_string f s ; Format.pp_print_string f s ;
| `Stacking_corner_case (loc,msg) -> | `Stacking_corner_case (loc,msg) ->
@ -59,7 +59,7 @@ let rec error_ppformat : display_format:string display_format ->
Format.pp_print_string f s ; Format.pp_print_string f s ;
| `Stacking_expression_tracer (e,ty,err) -> | `Stacking_expression_tracer (e,ty,err) ->
Format.fprintf f Format.fprintf f
"@[<hv>compiling expression@%a of type %a@%a]" "@[<hv>compiling expression %a@ of type %a@ %a]"
Mini_c.PP.expression e Mini_c.PP.expression e
Mini_c.PP.type_variable ty Mini_c.PP.type_variable ty
(error_ppformat ~display_format) err (error_ppformat ~display_format) err
@ -101,7 +101,7 @@ let rec error_jsonformat : stacking_error -> J.t = fun a ->
in in
match a with match a with
| `Stacking_get_environment (var,env) -> | `Stacking_get_environment (var,env) ->
let var' = Format.asprintf "%a" Var.pp var in let var' = Format.asprintf "%a" Var.pp var.wrap_content in
let env' = Format.asprintf "%a" Mini_c.PP.environment env in let env' = Format.asprintf "%a" Mini_c.PP.environment env in
let content = `Assoc [ let content = `Assoc [
("message", `String "failed to get var from environment"); ("message", `String "failed to get var from environment");

View File

@ -26,7 +26,7 @@ let record_sep value sep ppf (m : 'a label_map) =
fprintf ppf "%a" (list_sep new_pp sep) lst fprintf ppf "%a" (list_sep new_pp sep) lst
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev.wrap_content
let rec type_expression' : let rec type_expression' :
(formatter -> type_expression -> unit) (formatter -> type_expression -> unit)

View File

@ -100,13 +100,13 @@ let e_binop ?loc name a b = make_e ?loc @@ E_constant {cons_name = name ; argum
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst} let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_variable ?loc v = make_e ?loc @@ E_variable v let e_variable ?loc v = make_e ?loc @@ E_variable v
let e_variable_ez ?loc v = e_variable ?loc @@ Var.of_name v let e_variable_ez ?loc v = e_variable ?loc @@ Location.wrap ?loc (Var.of_name v)
let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b} let e_application ?loc a b = make_e ?loc @@ E_application {lamb=a ; args=b}
let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ E_lambda {binder; input_type; output_type; result} let e_lambda ?loc binder input_type output_type result : expression = make_e ?loc @@ E_lambda {binder; input_type; output_type; result}
let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda} let e_recursive ?loc fun_name fun_type lambda = make_e ?loc @@ E_recursive {fun_name; fun_type; lambda}
let e_recursive_ez ?loc fun_name fun_type lambda = e_recursive ?loc (Var.of_name fun_name) fun_type lambda (* let e_recursive_ez ?loc fun_name fun_type lambda = e_recursive ?loc (Var.of_name fun_name) fun_type lambda *)
let e_let_in ?loc let_binder inline rhs let_result = make_e ?loc @@ E_let_in { let_binder; rhs ; let_result; inline } let e_let_in ?loc let_binder inline rhs let_result = make_e ?loc @@ E_let_in { let_binder; rhs ; let_result; inline }
let e_let_in_ez ?loc binder ascr inline rhs let_result = e_let_in ?loc (Var.of_name binder, ascr) inline rhs let_result (* let e_let_in_ez ?loc binder ascr inline rhs let_result = e_let_in ?loc (Var.of_name binder, ascr) inline rhs let_result *)
let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code} let e_raw_code ?loc language code = make_e ?loc @@ E_raw_code {language; code}
let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_constructor ?loc s a : expression = make_e ?loc @@ E_constructor { constructor = Constructor s; element = a}
@ -135,8 +135,8 @@ let e_while ?loc condition body = make_e ?loc @@ E_while {condition; body}
let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body} let e_for ?loc binder start final increment body = make_e ?loc @@ E_for {binder;start;final;increment;body}
let e_for_each ?loc binder collection collection_type body = make_e ?loc @@ E_for_each {binder;collection;collection_type;body} let e_for_each ?loc binder collection collection_type body = make_e ?loc @@ E_for_each {binder;collection;collection_type;body}
let e_for_ez ?loc binder start final increment body = e_for ?loc (Var.of_name binder) start final increment body (* let e_for_ez ?loc binder start final increment body = e_for ?loc (Var.of_name binder) start final increment body *)
let e_for_each_ez ?loc (b,bo) collection collection_type body = e_for_each ?loc (Var.of_name b, Option.map Var.of_name bo) collection collection_type body (* let e_for_each_ez ?loc (b,bo) collection collection_type body = e_for_each ?loc (Var.of_name b, Option.map Var.of_name bo) collection collection_type body *)
let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit ()) let e_bool ?loc b : expression = e_constructor ?loc (string_of_bool b) (e_unit ())
@ -145,13 +145,13 @@ let e_matching_record ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_reco
let e_matching_tuple ?loc m lst ty_opt expr = e_matching ?loc m @@ Match_tuple (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_matching_variable ?loc m var ty_opt expr = e_matching ?loc m @@ Match_variable (var,ty_opt, expr)
let e_matching_tuple_ez ?loc m lst ty_opt expr = (* let e_matching_tuple_ez ?loc m lst ty_opt expr =
let lst = List.map Var.of_name lst in let lst = List.map Var.of_name lst in
e_matching_tuple ?loc m lst ty_opt expr e_matching_tuple ?loc m lst ty_opt expr *)
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 *)
let e_record ?loc map = make_e ?loc @@ E_record map let e_record ?loc map = make_e ?loc @@ E_record map
let e_record_ez ?loc (lst : (string * expr) list) : expression = let e_record_ez ?loc (lst : (string * expr) list) : expression =
@ -181,7 +181,7 @@ let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k)
let e_assign ?loc variable access_path expression = make_e ?loc @@ E_assign {variable;access_path;expression} let e_assign ?loc variable access_path expression = make_e ?loc @@ E_assign {variable;access_path;expression}
let e_assign_ez ?loc variable access_path expression = e_assign ?loc (Var.of_name variable) access_path expression let e_assign_ez ?loc variable access_path expression = e_assign ?loc (Location.wrap ?loc @@ Var.of_name variable) access_path expression
let get_e_accessor = fun t -> let get_e_accessor = fun t ->

View File

@ -87,21 +87,21 @@ val e_variable_ez : ?loc:Location.t -> string -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression
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_recursive_ez : ?loc:Location.t -> string -> type_expression -> lambda -> expression (* val e_recursive_ez : ?loc:Location.t -> string -> type_expression -> lambda -> expression *)
val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression
val e_let_in_ez : ?loc:Location.t -> string -> type_expression option -> bool -> expression -> expression -> expression (* val e_let_in_ez : ?loc:Location.t -> string -> type_expression option -> bool -> expression -> expression -> expression *)
val e_raw_code : ?loc:Location.t -> string -> expression -> expression val e_raw_code : ?loc:Location.t -> string -> expression -> expression
val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression
val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression
val ez_match_variant : ((string * string ) * expression) list -> matching_expr (* val ez_match_variant : ((string * string ) * expression) list -> matching_expr *)
val e_matching_variant : ?loc:Location.t -> expression -> ((constructor' * expression_variable) * expression) list -> expression val e_matching_variant : ?loc:Location.t -> expression -> ((constructor' * expression_variable) * expression) list -> expression
val e_matching_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> 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_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_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> expression
val e_matching_tuple_ez: ?loc:Location.t -> expression -> string list -> type_expression list option -> expression -> expression (* val e_matching_tuple_ez: ?loc:Location.t -> expression -> string list -> type_expression list option -> expression -> expression *)
val e_record : ?loc:Location.t -> expr label_map -> expression val e_record : ?loc:Location.t -> expr label_map -> expression
val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression val e_record_ez : ?loc:Location.t -> ( string * expr ) list -> expression
@ -129,8 +129,8 @@ val e_while : ?loc:Location.t -> expression -> expression -> expression
val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression val e_for : ?loc:Location.t -> expression_variable -> expression -> expression -> expression -> expression -> expression
val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression val e_for_each : ?loc:Location.t -> expression_variable * expression_variable option -> expression -> collect_type -> expression -> expression
val e_for_ez : ?loc:Location.t -> string -> expression -> expression -> expression -> expression -> expression (* val e_for_ez : ?loc:Location.t -> string -> expression -> expression -> expression -> expression -> expression
val e_for_each_ez : ?loc:Location.t -> string * string option -> expression -> collect_type -> expression -> expression val e_for_each_ez : ?loc:Location.t -> string * string option -> expression -> collect_type -> expression -> 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

View File

@ -22,7 +22,7 @@ let record_sep_t value sep ppf (m : 'a label_map) =
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev.wrap_content
let rec type_expression' : let rec type_expression' :
(formatter -> type_expression -> unit) (formatter -> type_expression -> unit)

View File

@ -87,7 +87,7 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_
fprintf ppf "(type_operator: %s)" s fprintf ppf "(type_operator: %s)" s
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev.wrap_content
let rec expression ppf (e : expression) = let rec expression ppf (e : expression) =

View File

@ -54,7 +54,7 @@ let t_contract ?loc ?sugar contract : type_expression = make_t ?loc ?sugar @
let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc } let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc }
let e_var ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_variable (Var.of_name n) let e_var ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_variable (Location.wrap ?loc (Var.of_name n))
let e_literal ?loc ?sugar l : expression = make_e ?loc ?sugar @@ E_literal l let e_literal ?loc ?sugar l : expression = make_e ?loc ?sugar @@ E_literal l
let e_unit ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_literal (Literal_unit) let e_unit ?loc ?sugar () : expression = make_e ?loc ?sugar @@ E_literal (Literal_unit)
let e_int ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_int n) let e_int ?loc ?sugar n : expression = make_e ?loc ?sugar @@ E_literal (Literal_int n)

View File

@ -258,7 +258,7 @@ and type_operator :
(* end include Stage_common.PP *) (* end include Stage_common.PP *)
let expression_variable ppf (ev : expression_variable) : unit = let expression_variable ppf (ev : expression_variable) : unit =
fprintf ppf "%a" Var.pp ev fprintf ppf "%a" Var.pp ev.wrap_content
let rec expression ppf (e : expression) = let rec expression ppf (e : expression) =

View File

@ -64,7 +64,7 @@ module M = struct
bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ; bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ;
unit = (fun _visitor NoState () -> fprintf ppf "()") ; unit = (fun _visitor NoState () -> fprintf ppf "()") ;
packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ; packed_internal_operation = (fun _visitor NoState _op -> fprintf ppf "Operation(...bytes)") ;
expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev) ; expression_variable = (fun _visitor NoState ev -> fprintf ppf "%a" Var.pp ev.wrap_content) ;
constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ; constructor' = (fun _visitor NoState (Constructor c) -> fprintf ppf "Constructor %s" c) ;
location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ; location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ;
label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ; label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ;

View File

@ -31,7 +31,7 @@ module M = struct
bytes = (fun _visitor NoState bytes -> `String (Bytes.to_string bytes)) ; bytes = (fun _visitor NoState bytes -> `String (Bytes.to_string bytes)) ;
unit = (fun _visitor NoState () -> `String "unit" ) ; unit = (fun _visitor NoState () -> `String "unit" ) ;
packed_internal_operation = (fun _visitor NoState _op -> `String "Operation(...bytes)") ; packed_internal_operation = (fun _visitor NoState _op -> `String "Operation(...bytes)") ;
expression_variable = (fun _visitor NoState ev -> `Assoc ["exp-var", `String (asprintf "%a" Var.pp ev)] ) ; expression_variable = (fun _visitor NoState ev -> `Assoc ["exp-var", `String (asprintf "%a" Var.pp ev.wrap_content)] ) ;
constructor' = (fun _visitor NoState (Constructor c) -> `Assoc ["constructor", `String c] ) ; constructor' = (fun _visitor NoState (Constructor c) -> `Assoc ["constructor", `String c] ) ;
location = (fun _visitor NoState loc -> `String (asprintf "%a" Location.pp loc) ) ; (*TODO*) location = (fun _visitor NoState loc -> `String (asprintf "%a" Location.pp loc) ) ; (*TODO*)
label = (fun _visitor NoState (Label lbl) -> `Assoc ["label" , `String lbl] ) ; label = (fun _visitor NoState (Label lbl) -> `Assoc ["label" , `String lbl] ) ;

View File

@ -335,7 +335,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration option = fun p name -> let get_declaration_by_name : program -> string -> declaration option = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with match declaration with
| Declaration_constant { binder ; expr=_ ; inline=_ } -> binder = Var.of_name name | Declaration_constant { binder ; expr=_ ; inline=_ } -> binder.wrap_content = Var.of_name name
| Declaration_type _ -> false | Declaration_type _ -> false
in in
List.find_opt aux @@ List.map Location.unwrap p List.find_opt aux @@ List.map Location.unwrap p

View File

@ -146,7 +146,7 @@ module M = struct
| (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b | (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b
| (Bytes a, Bytes b) -> Bytes.compare a b | (Bytes a, Bytes b) -> Bytes.compare a b
| (Constructor' a, Constructor' b) -> String.compare a b | (Constructor' a, Constructor' b) -> String.compare a b
| (Expression_variable a, Expression_variable b) -> Var.compare a b | (Expression_variable a, Expression_variable b) -> Var.compare a.wrap_content b.wrap_content
| (Int a, Int b) -> Int.compare a b | (Int a, Int b) -> Int.compare a b
| (Label' a, Label' b) -> String.compare a b | (Label' a, Label' b) -> String.compare a b
| (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b | (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b

View File

@ -27,7 +27,7 @@ let add_type : type_variable -> type_expression -> t -> t = fun type_variable ty
(* TODO: generate : these are now messy, clean them up. *) (* TODO: generate : these are now messy, clean them up. *)
let get_opt : expression_variable -> t -> element option = fun k x -> let get_opt : expression_variable -> t -> element option = fun k x ->
Option.bind (fun {expr_var=_ ; env_elt} -> Some env_elt) @@ Option.bind (fun {expr_var=_ ; env_elt} -> Some env_elt) @@
List.find_opt (fun {expr_var ; env_elt=_} -> Var.equal expr_var k) (get_expr_environment x) List.find_opt (fun {expr_var ; env_elt=_} -> Var.equal expr_var.wrap_content k.wrap_content) (get_expr_environment x)
let get_type_opt : type_variable -> t -> type_expression option = fun k x -> let get_type_opt : type_variable -> t -> type_expression option = fun k x ->
Option.bind (fun {type_variable=_ ; type_} -> Some type_) @@ Option.bind (fun {type_variable=_ ; type_} -> Some type_) @@
List.find_opt (fun {type_variable ; type_=_} -> Var.equal type_variable k) (get_type_environment x) List.find_opt (fun {type_variable ; type_=_} -> Var.equal type_variable k) (get_type_environment x)

View File

@ -3,7 +3,8 @@ open Types
module Free_variables = struct module Free_variables = struct
type bindings = expression_variable list type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem let var_compare = Location.compare_content ~compare:Var.compare
let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare
let singleton : expression_variable -> bindings = fun s -> [ s ] let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat
@ -219,7 +220,7 @@ let get_entry (lst : program) (name : string) : expression option =
let aux x = let aux x =
match Location.unwrap x with match Location.unwrap x with
| Declaration_constant { binder ; expr ; inline=_ } -> ( | Declaration_constant { binder ; expr ; inline=_ } -> (
if Var.equal binder (Var.of_name name) if Var.equal binder.wrap_content (Var.of_name name)
then Some expr then Some expr
else None else None
) )
@ -229,7 +230,7 @@ let get_entry (lst : program) (name : string) : expression option =
let equal_variables a b : bool = let equal_variables a b : bool =
match a.expression_content, b.expression_content with match a.expression_content, b.expression_content with
| E_variable a, E_variable b -> Var.equal a b | E_variable a, E_variable b -> Var.equal a.wrap_content b.wrap_content
| _, _ -> false | _, _ -> false
let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = { let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = {

View File

@ -6,7 +6,8 @@ open Misc
module Captured_variables = struct module Captured_variables = struct
type bindings = expression_variable list type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem let var_compare = Location.compare_content ~compare:Var.compare
let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare
let singleton : expression_variable -> bindings = fun s -> [ s ] let singleton : expression_variable -> bindings = fun s -> [ s ]
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat

View File

@ -24,7 +24,7 @@ and annotated ppf : type_expression annotated -> _ = function
| (None, a) -> type_variable ppf a | (None, a) -> type_variable ppf a
and environment_element ppf ((n, tv) : environment_element) = and environment_element ppf ((n, tv) : environment_element) =
Format.fprintf ppf "%a : %a" Var.pp n type_variable tv Format.fprintf ppf "%a : %a" Var.pp n.wrap_content type_variable tv
and environment ppf (x:environment) = and environment ppf (x:environment) =
fprintf ppf "Env[%a]" (list_sep_d environment_element) x fprintf ppf "Env[%a]" (list_sep_d environment_element) x
@ -94,7 +94,7 @@ and expression ppf (e:expression) =
and expression_content ppf (e:expression_content) = match e with and expression_content ppf (e:expression_content) = match e with
| E_skip -> fprintf ppf "skip" | E_skip -> fprintf ppf "skip"
| E_closure x -> function_ ppf x | E_closure x -> function_ ppf x
| E_variable v -> fprintf ppf "%a" Var.pp v | E_variable v -> fprintf ppf "%a" Var.pp v.wrap_content
| E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b | E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b
| E_constant c -> fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments | E_constant c -> fprintf ppf "@[%a@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments
@ -107,19 +107,21 @@ and expression_content ppf (e:expression_content) = match e with
| E_if_none (c, n, ((name, _) , s)) -> | E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf fprintf ppf
"@[match %a with@ @[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]" "@[match %a with@ @[<hv>| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]"
expression c expression n Var.pp name expression s expression c expression n Var.pp name.wrap_content expression s
| E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) ->
fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]"
expression c expression n Var.pp hd_name.wrap_content Var.pp tl_name.wrap_content expression cons
| E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) ->
fprintf ppf fprintf ppf
"@[match %a with@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]" "@[match %a with@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]"
expression c Var.pp name_l expression l Var.pp name_r expression r expression c Var.pp name_l.wrap_content expression l Var.pp name_r.wrap_content expression r
| E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b | E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b
| E_let_in ((name , _) , inline, expr , body) -> | E_let_in ((name , _) , inline, expr , body) ->
fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name.wrap_content expression expr option_inline inline expression body
| E_iterator (b , ((name , _) , body) , expr) -> | E_iterator (b , ((name , _) , body) , expr) ->
fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name.wrap_content expression expr expression body
| E_fold (((name , _) , body) , collection , initial) -> | E_fold (((name , _) , body) , collection , initial) ->
fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name.wrap_content expression body
| E_record_update (r, path,update) -> | E_record_update (r, path,update) ->
fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update
@ -135,7 +137,7 @@ and expression_with_type : _ -> expression -> _ = fun ppf e ->
and function_ ppf ({binder ; body}:anon_function) = and function_ ppf ({binder ; body}:anon_function) =
fprintf ppf "@[fun %a ->@ (%a)@]" fprintf ppf "@[fun %a ->@ (%a)@]"
Var.pp binder Var.pp binder.wrap_content
expression body expression body
and option_inline ppf inline = and option_inline ppf inline =
@ -144,7 +146,7 @@ and option_inline ppf inline =
else else
fprintf ppf "" fprintf ppf ""
and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n.wrap_content expression e option_inline i
and tl_statement ppf (ass, _) = declaration ppf ass and tl_statement ppf (ass, _) = declaration ppf ass
@ -278,11 +280,13 @@ let%expect_test _ =
let pp = expression_content Format.std_formatter in let pp = expression_content Format.std_formatter in
let dummy_type = {type_content=T_base TB_unit;location=Location.generated} in let dummy_type = {type_content=T_base TB_unit;location=Location.generated} in
let wrap e = { content = e ; type_expression = dummy_type ; location = Location.generated} in let wrap e = { content = e ; type_expression = dummy_type ; location = Location.generated} in
pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ; let y = Location.wrap ~loc:(Location.generated) (Var.of_name "y") in
let z = Location.wrap ~loc:(Location.generated) (Var.of_name "z") in
pp @@ E_closure { binder = y ; body = wrap (E_variable y) } ;
[%expect{| [%expect{|
fun y -> (y) fun y -> (y)
|}] ; |}] ;
pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ; pp @@ E_closure { binder = z ; body = wrap (E_variable z) } ;
[%expect{| [%expect{|
fun z -> (z) fun z -> (z)
|}] |}]

View File

@ -3,4 +3,4 @@ open Combinators
let basic_int_quote_env : environment = let basic_int_quote_env : environment =
let e = Environment.empty in let e = Environment.empty in
Environment.add (Var.of_name "input", t_int ()) e Environment.add (Location.wrap @@ Var.of_name "input", t_int ()) e

View File

@ -18,15 +18,18 @@ module Environment (* : ENVIRONMENT *) = struct
type element = environment_element type element = environment_element
type t = environment type t = environment
let compare_var : expression_variable -> expression_variable -> int =
fun a b -> Var.compare a.wrap_content b.wrap_content
let empty : t = [] let empty : t = []
let add : element -> t -> t = List.cons let add : element -> t -> t = List.cons
let concat : t list -> t = List.concat let concat : t list -> t = List.concat
let get_opt : expression_variable -> t -> type_expression option = List.assoc_opt ~compare:Var.compare let get_opt : expression_variable -> t -> type_expression option = List.assoc_opt ~compare:compare_var
let has : expression_variable -> t -> bool = fun s t -> let has : expression_variable -> t -> bool = fun s t ->
match get_opt s t with match get_opt s t with
| None -> false | None -> false
| Some _ -> true | Some _ -> true
let get_i : expression_variable -> t -> (type_expression * int) = List.assoc_i ~compare:Var.compare let get_i : expression_variable -> t -> (type_expression * int) = List.assoc_i ~compare:compare_var
let of_list : element list -> t = fun x -> x let of_list : element list -> t = fun x -> x
let to_list : t -> element list = fun x -> x let to_list : t -> element list = fun x -> x
let get_names : t -> expression_variable list = List.map fst let get_names : t -> expression_variable list = List.map fst
@ -36,8 +39,8 @@ module Environment (* : ENVIRONMENT *) = struct
let e_lst = let e_lst =
let e_lst = to_list env in let e_lst = to_list env in
let aux selector (s , _) = let aux selector (s , _) =
match List.mem ~compare:Var.compare s selector with match List.mem ~compare:compare_var s selector with
| true -> List.remove_element ~compare:Var.compare s selector , keep | true -> List.remove_element ~compare:compare_var s selector , keep
| false -> selector , not keep in | false -> selector , not keep in
let e_lst' = let e_lst' =
if rev = keep if rev = keep

View File

@ -4,11 +4,13 @@ open Combinators
module Free_variables = struct module Free_variables = struct
type bindings = expression_variable list type bindings = expression_variable list
let mem : expression_variable -> bindings -> bool = List.mem let var_equal = Location.equal_content ~equal:Var.equal
let var_compare = Location.compare_content ~compare:Var.compare
let mem : expression_variable -> bindings -> bool = List.mem ~compare:var_compare
let singleton : expression_variable -> bindings = fun s -> [ s ] let singleton : expression_variable -> bindings = fun s -> [ s ]
let mem_count : expression_variable -> bindings -> int = let mem_count : expression_variable -> bindings -> int =
fun x fvs -> fun x fvs ->
List.length (List.filter (Var.equal x) fvs) List.length (List.filter (var_equal x) fvs)
let union : bindings -> bindings -> bindings = (@) let union : bindings -> bindings -> bindings = (@)
let unions : bindings list -> bindings = List.concat let unions : bindings list -> bindings = List.concat
let empty : bindings = [] let empty : bindings = []
@ -98,8 +100,8 @@ end
let get_entry (lst : program) (name : string) : (expression * int) option = let get_entry (lst : program) (name : string) : (expression * int) option =
let entry_expression = let entry_expression =
let aux x = let aux x =
let (((decl_name , _, decl_expr) , _)) = x in let ((((decl_name:expression_variable) , _, decl_expr) , _)) = x in
if (Var.equal decl_name (Var.of_name name)) if (Var.equal decl_name.wrap_content (Var.of_name name))
then Some decl_expr then Some decl_expr
else None else None
in in
@ -109,8 +111,8 @@ let get_entry (lst : program) (name : string) : (expression * int) option =
| Some exp -> | Some exp ->
let entry_index = let entry_index =
let aux x = let aux x =
let (((decl_name , _, _) , _)) = x in let ((((decl_name:expression_variable) , _, _) , _)) = x in
Var.equal decl_name (Var.of_name name) Var.equal decl_name.wrap_content (Var.of_name name)
in in
(List.length lst) - (List.find_index aux (List.rev lst)) - 1 (List.length lst) - (List.find_index aux (List.rev lst)) - 1
in in

View File

@ -1,5 +1,5 @@
type expression_ type expression_
and expression_variable = expression_ Var.t and expression_variable = expression_ Var.t Location.wrap
type type_ type type_
and type_variable = type_ Var.t and type_variable = type_ Var.t

View File

@ -34,7 +34,7 @@ let rec pp_value : value -> string = function
let pp_env : env -> unit = fun env -> let pp_env : env -> unit = fun env ->
let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in
let () = Env.iter (fun var v -> let () = Env.iter (fun var v ->
Format.printf "\t%a -> %s\n" Var.pp var (pp_value v)) Format.printf "\t%a -> %s\n" Var.pp var.wrap_content (pp_value v))
env in env in
let () = Format.printf "\n}\n" in let () = Format.printf "\n}\n" in
() ()

View File

@ -4,7 +4,7 @@ include Ast_typed.Types
module Env = Map.Make( module Env = Map.Make(
struct struct
type t = expression_variable type t = expression_variable
let compare a b = Var.compare a b let compare (a:expression_variable) (b:expression_variable) = Var.compare a.wrap_content b.wrap_content
end end
) )

View File

@ -45,7 +45,7 @@ let (first_committer , first_contract) =
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list

View File

@ -45,7 +45,7 @@ let init_storage threshold counter pkeys =
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list
let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode

View File

@ -28,12 +28,12 @@ open Ast_imperative
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_bytes ())) (Some (t_list (t_operation ()))) (Some (t_bytes ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list
let empty_message2 = e_lambda (Var.of_name "arguments") let empty_message2 = e_lambda (Location.wrap @@ 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 (e_unit ()) empty_op_list) ( e_let_in ((Location.wrap @@ 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

View File

@ -39,7 +39,7 @@ let (stranger_addr , stranger_contract) =
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list

View File

@ -28,7 +28,7 @@ open Ast_imperative
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list

View File

@ -28,7 +28,7 @@ let compile_main () =
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list

View File

@ -29,7 +29,7 @@ open Ast_imperative
let empty_op_list = let empty_op_list =
(e_typed_list [] (t_operation ())) (e_typed_list [] (t_operation ()))
let empty_message = e_lambda (Var.of_name "arguments") let empty_message = e_lambda (Location.wrap @@ Var.of_name "arguments")
(Some (t_unit ())) (Some (t_list (t_operation ()))) (Some (t_unit ())) (Some (t_list (t_operation ())))
empty_op_list empty_op_list

View File

@ -47,7 +47,7 @@ module TestExpressions = struct
let lambda () : (unit, _) result = let lambda () : (unit, _) result =
test_expression test_expression
I.(e_lambda (Var.of_name "x") (Some (t_int ())) (Some (t_int ())) (e_var "x")) I.(e_lambda (Location.wrap @@ Var.of_name "x") (Some (t_int ())) (Some (t_int ())) (e_var "x"))
O.(t_function (t_int ()) (t_int ()) ()) O.(t_function (t_int ()) (t_int ()) ())
let tuple () : (unit, _) result = let tuple () : (unit, _) result =

View File

@ -46,6 +46,12 @@ let compare_wrap ~compare:compare_content { wrap_content = wca ; location = la }
| 0 -> compare la lb | 0 -> compare la lb
| c -> c | c -> c
let compare_content ~compare:compare_content wa wb =
compare_content wa.wrap_content wb.wrap_content
let equal_content ~equal:equal_content wa wb =
equal_content wa.wrap_content wb.wrap_content
let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc } let wrap ?(loc = generated) wrap_content = { wrap_content ; location = loc }
let get_location x = x.location let get_location x = x.location
let unwrap { wrap_content ; _ } = wrap_content let unwrap { wrap_content ; _ } = wrap_content