diff --git a/src/main/compile/of_core.ml b/src/main/compile/of_core.ml index e7fb6511f..818e17ffb 100644 --- a/src/main/compile/of_core.ml +++ b/src/main/compile/of_core.ml @@ -22,7 +22,7 @@ let compile_expression ?(env = Ast_typed.Environment.empty) ~(state : Typesystem ok @@ (ae_typed',state) 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 = { content = Ast_core.E_variable name ; sugar = None ; @@ -39,6 +39,6 @@ let list_declarations (program : Ast_core.program) : string list = let open Location in let open Ast_core in match el.wrap_content with - | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev + | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev | _ -> prev) [] program diff --git a/src/main/compile/of_imperative.ml b/src/main/compile/of_imperative.ml index eb60d2fdd..86a3a5f2a 100644 --- a/src/main/compile/of_imperative.ml +++ b/src/main/compile/of_imperative.ml @@ -17,6 +17,6 @@ let list_declarations (program : program) : string list = (fun prev el -> let open Location in match el.wrap_content with - | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev + | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev | _ -> prev) [] program diff --git a/src/main/compile/of_sugar.ml b/src/main/compile/of_sugar.ml index b35b70d41..9a8025894 100644 --- a/src/main/compile/of_sugar.ml +++ b/src/main/compile/of_sugar.ml @@ -14,6 +14,6 @@ let list_declarations (program : program) : string list = (fun prev el -> let open Location in match el.wrap_content with - | Declaration_constant (var,_,_,_) -> (Var.to_name var)::prev + | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev | _ -> prev) [] program diff --git a/src/passes/03-tree_abstraction/cameligo/compiler.ml b/src/passes/03-tree_abstraction/cameligo/compiler.ml index 2a50c00e1..c875a333d 100644 --- a/src/passes/03-tree_abstraction/cameligo/compiler.ml +++ b/src/passes/03-tree_abstraction/cameligo/compiler.ml @@ -195,7 +195,7 @@ let rec compile_expression : let (p , loc) = r_split p in let var = 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' = let aux (s:Raw.selection) = @@ -222,7 +222,7 @@ let rec compile_expression : let compile_update (u: Raw.update Region.reg) = let u, loc = r_split u 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 updates = u.updates.value.ne_elements in let%bind updates' = @@ -248,7 +248,7 @@ in trace (abstracting_expr_tracer t) @@ 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 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 = match ty_opt with 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 prepare_variable (ty_var: Raw.variable * Raw.type_expr option) = 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 = match ty_opt with | Some ty -> bind_map_option compile_type_expression (Some ty) @@ -343,7 +344,7 @@ in trace (abstracting_expr_tracer t) @@ | EVar c -> let (c',loc) = r_split c in (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 []) | ECall x -> ( let ((e1 , e2) , loc) = r_split x in @@ -357,7 +358,7 @@ in trace (abstracting_expr_tracer t) @@ | EVar f -> ( let (f , f_loc) = r_split f in 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 ) | e1 -> @@ -463,7 +464,8 @@ in trace (abstracting_expr_tracer t) @@ let x' = x.value in match x'.pattern with | 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 return @@ e_let_in (var_name , Some type_expr) false e rhs | _ -> default_action () @@ -603,8 +605,9 @@ and compile_fun lamb' : (expr , abs_error) result = let rec layer_arguments (arguments: (Raw.variable * type_expression) list) = match arguments with | hd :: tl -> + let (hd_binder,hd_loc) = r_split (fst hd) in 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) | [] -> body in @@ -705,7 +708,8 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a | None -> ok None 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 expr_bind_lst = match let_rhs with @@ -789,7 +793,8 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a ) | Some t -> ok @@ Some t 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 None -> ok @@ rhs' | Some _ -> match rhs'.expression_content with @@ -797,11 +802,11 @@ and compile_declaration : Raw.declaration -> (declaration Location.wrap list , a (match lhs_type with None -> fail @@ untyped_recursive_fun var.Region.region | 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' 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 = @@ -840,8 +845,7 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error let%bind pat = trace_option (unsupported_cst_constr t) @@ pat_opt in let%bind single_pat = get_single pat in - let%bind var = get_var single_pat in - ok (const.value, var) + ok (const.value, single_pat) | _ -> fail @@ only_constructors t in let rec get_constr_opt (t:Raw.pattern) = match t with @@ -859,8 +863,7 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error | None -> ok None | Some pat -> let%bind single_pat = get_single pat in - let%bind var = get_var single_pat in - ok (Some var) + ok (Some single_pat) in ok (const.value , var_opt) | _ -> fail @@ only_constructors t in let%bind patterns = @@ -873,7 +876,8 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error match patterns with | [(PFalse _, f) ; (PTrue _, t)] | [(PTrue _, t) ; (PFalse _, f)] -> - ok @@ Match_variant ([((Constructor "true", Var.of_name "_"), t); ((Constructor "false", Var.of_name "_"), f)]) + 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 (PListComp sugar_nil), nil); (PList (PCons c), cons)] -> let%bind () = @@ -882,19 +886,26 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error @@ sugar_nil.value.elements in let%bind (a, b) = 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 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 @@ 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 -> let as_variant () = trace_strong (unsupported_pattern_type (List.map fst lst)) @@ let%bind constrs = let aux (x, y) = - let%bind x' = get_constr x - in ok (x', y) + let%bind (c,v) = get_constr x in + 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 ok @@ ez_match_variant constrs in + in ok @@ Match_variant constrs in let as_option () = trace_strong (unsupported_pattern_type (List.map fst lst)) @@ let aux (x, y) = @@ -906,9 +917,12 @@ and compile_cases : (Raw.pattern * expression) list -> (matching_expr, abs_error (("None" , None) , none_expr) ] | [ (("None", None), none_expr); (("Some", Some some_var), some_expr) ] -> - ok @@ Match_option { - match_some = (Var.of_name some_var, some_expr); - match_none = none_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 { + match_some = (proj, some_expr); + match_none = none_expr } | _ -> fail @@ corner_case "bad option pattern" in bind_or (as_option () , as_variant ()) diff --git a/src/passes/03-tree_abstraction/cameligo/decompiler.ml b/src/passes/03-tree_abstraction/cameligo/decompiler.ml index 138d896e3..e278d25a1 100644 --- a/src/passes/03-tree_abstraction/cameligo/decompiler.ml +++ b/src/passes/03-tree_abstraction/cameligo/decompiler.ml @@ -98,7 +98,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te -> let get_e_variable : AST.expression -> _ result = fun expr -> match expr.expression_content with - E_variable var -> ok @@ var + E_variable var -> ok @@ var.wrap_content | _ -> failwith @@ Format.asprintf "%a should be a variable expression" 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 match expr.expression_content with E_variable name -> - let var = decompile_variable name in + let var = decompile_variable name.wrap_content in return_expr @@ CST.EVar (var) | E_constant {cons_name; arguments} -> 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 _ -> failwith "corner case : annonymous recursive function" | 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%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 @@ -263,7 +263,7 @@ let rec decompile_expression : AST.expression -> _ result = fun expr -> Access_record var::path -> ok @@ (var,path) | _ -> failwith "Impossible case %a" 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 field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} 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 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 [] -> ok @@ CST.Name struct_name | lst -> @@ -399,7 +399,7 @@ and decompile_to_selection : AST.access -> (CST.selection, _) result = fun acces "Can't decompile access_map to selection" 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%bind ret_type = bind_map_option (bind_compose (ok <@ prefix_colon) decompile_type_expr) output_type 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 -> let%bind cases = match m with 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 case : _ CST.case_clause = {pattern; arrow=rg; rhs}in ok @@ [wrap case] @@ -425,9 +425,9 @@ fun m -> let%bind type_expr = decompile_type_expr ty in ok @@ CST.PTyped (wrap @@ CST.{pattern;colon=rg;type_expr}) 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 -> - 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 in let pattern : CST.pattern = PTuple (wrap @@ tuple) in @@ -439,13 +439,13 @@ fun m -> let%bind rhs = decompile_expression match_none 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 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 ok @@ [wrap some_case;wrap none_case] | Match_list {match_nil; match_cons} -> let (hd,tl,expr) = match_cons in - let hd = CST.PVar (decompile_variable hd) in - let tl = CST.PVar (decompile_variable tl) in + let hd = CST.PVar (decompile_variable hd.wrap_content) in + let tl = CST.PVar (decompile_variable tl.wrap_content) in let cons = (hd,rg,tl) in let%bind rhs = decompile_expression @@ expr 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 ok @@ [wrap cons_case; wrap nil_case] | Match_variant lst -> - let aux ((c,v),e) = + let aux ((c,(v:AST.expression_variable)),e) = let AST.Constructor c = 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 pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) 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})) | Declaration_constant (var, ty_opt, inline, expr) -> 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 match expr.expression_content with E_lambda lambda -> diff --git a/src/passes/03-tree_abstraction/pascaligo/compiler.ml b/src/passes/03-tree_abstraction/pascaligo/compiler.ml index 59f258b29..22fbb8e7a 100644 --- a/src/passes/03-tree_abstraction/pascaligo/compiler.ml +++ b/src/passes/03-tree_abstraction/pascaligo/compiler.ml @@ -282,32 +282,32 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e - match param with ParamConst p -> 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 - return (var, p_type) + return (Location.wrap ?loc:(Some loc) @@ Var.of_name var, p_type) | ParamVar p -> 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 - return (var, p_type) + return (Location.wrap ?loc:(Some loc) @@ Var.of_name var, p_type) in let (func, loc) = r_split func in let (param, loc_par) = r_split func.param in - let%bind param = bind_map_list compile_param @@ npseq_to_list param.inside in + let%bind param = bind_map_list compile_param @@ npseq_to_list param.inside in let (param, param_type) = List.split param in let%bind ret_type = bind_map_option (compile_type_expression <@ snd )func.ret_type in let%bind body = compile_expression func.return in let (lambda, fun_type) = match param_type with 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) (* Cannot be empty *) | lst -> let lst = Option.bind_list 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_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) in return @@ Option.unopt ~default:lambda @@ @@ -443,7 +443,11 @@ fun compiler cases -> tl::[] -> return (fst cons,tl) | _ -> fail @@ unsupported_deep_list_patterns @@ fst cons 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 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 return (match_nil,match_cons) | _ -> fail @@ unsupported_deep_list_patterns @@ fst @@ List.hd cases @@ -460,21 +464,24 @@ fun compiler cases -> ( match c with PUnit _ -> fail @@ unsupported_pattern_type constr - | PFalse _ -> return (Constructor "false", Var.of_name "_") - | PTrue _ -> return (Constructor "true", Var.of_name "_") - | PNone _ -> return (Constructor "None", Var.of_name "_") + | PFalse _ -> return (Constructor "false", Location.wrap @@ Var.of_name "_") + | PTrue _ -> return (Constructor "true", Location.wrap @@ Var.of_name "_") + | PNone _ -> return (Constructor "None", Location.wrap @@ Var.of_name "_") | PSomeApp some -> let (some,_) = r_split 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 - return (Constructor "Some", pattern) + return (Constructor "Some", Location.wrap ?loc:(Some loc) pattern) | PConstrApp constr -> let (constr, _) = r_split constr in let (constr, patterns) = 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 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) ) | _ -> fail @@ unsupported_pattern_type constr @@ -488,8 +495,8 @@ fun compiler cases -> let%bind cases = bind_map_ne_list aux cases in match cases with | (PVar var, expr), [] -> - let (var, _) = r_split var in - let var = Var.of_name var in + let (var, loc) = r_split var in + let var = Location.wrap ?loc:(Some loc) @@ Var.of_name var in return @@ AST.Match_variable (var, None, expr) | (PTuple tuple, _expr), [] -> fail @@ unsupported_tuple_pattern @@ CST.PTuple tuple @@ -511,12 +518,14 @@ and compile_parameters (params : CST.parameters) = match param with ParamConst pc -> 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 return (var, param_type) | ParamVar pv -> 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 return (var, param_type) in @@ -600,27 +609,32 @@ and compile_instruction : ?next: AST.expression -> CST.instruction -> _ result return @@ e_while ~loc cond body | Loop (For (ForInt fl)) -> 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 bound = compile_expression fl.bound in let%bind increment = Option.unopt ~default:(ok @@ e_int_z Z.one) @@ Option.map (compile_expression <@ snd) fl.step 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)) -> let (el, loc) = r_split el in let binder = - let (key, _) = r_split el.var in - let value = Option.map (fun x -> fst (r_split (snd x))) el.bind_to in - (key,value) + let (key, loc) = r_split el.var in + let key' = Location.wrap ?loc:(Some loc) @@ Var.of_name key in + 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 let%bind collection = compile_expression el.expr in let (collection_type, _) = match el.collection with Map loc -> (Map, loc) | Set loc -> (Set, loc) | List loc -> (List, loc) 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} -> let loc = Location.lift region 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 -> let return loc name type_ init = 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 LocalConst const_decl -> 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 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 -> 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 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 -> let (fun_decl,loc) = r_split 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) = let%bind attr = compile_attribute_declaration attributes 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 param = compile_parameters param 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 ty::[] -> let lambda : AST.lambda = { - binder = (Var.of_name @@ List.hd param); + binder = List.hd param; input_type = ty ; output_type = ret_type ; result; @@ -758,25 +775,25 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attri | lst -> let lst = Option.bind_list 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 = { binder; input_type = input_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 - 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) ) in (* This handle the recursion *) let%bind func = match kwd_recursive with Some reg -> 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 -> return @@ make_e ~loc @@ E_lambda lambda 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 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 return region @@ AST.Declaration_type (Var.of_name name, type_expr) | 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%bind const_type = bind_map_option (compile_type_expression <@ snd) const_type in let%bind init = compile_expression init 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} -> let value = {value with attributes = attr} in (*ATR*) 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*) (* This should be change to the commented function when attributes are fixed diff --git a/src/passes/03-tree_abstraction/pascaligo/decompiler.ml b/src/passes/03-tree_abstraction/pascaligo/decompiler.ml index 6276c2521..999812f98 100644 --- a/src/passes/03-tree_abstraction/pascaligo/decompiler.ml +++ b/src/passes/03-tree_abstraction/pascaligo/decompiler.ml @@ -99,7 +99,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te -> let get_e_variable : AST.expression -> _ result = fun expr -> match expr.expression_content with - E_variable var -> ok @@ var + E_variable var -> ok @@ var.wrap_content | _ -> failwith @@ Format.asprintf "%a should be a variable expression" 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 match expr.expression_content with E_variable name -> - let var = decompile_variable name in + let var = decompile_variable name.wrap_content in return_expr @@ CST.EVar (var) | E_constant {cons_name; arguments} -> 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) | E_recursive _ -> 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 Access_map e :: path -> 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) | _ -> failwith "Impossible case %a" 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 field_assign : CST.field_path_assignment = {field_path;assignment=rg;field_expr} 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 return_inst @@ Assign (wrap assign) | 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 bound = decompile_expression final 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 return_inst @@ CST.Loop (For (ForInt (wrap fl))) | E_for_each {binder;collection;collection_type;body} -> - let var = decompile_variable @@ fst binder in - let bind_to = Option.map (fun x -> (rg,decompile_variable x)) @@ snd binder in + let var = decompile_variable @@ (fst binder).wrap_content 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 collection = match collection_type with 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)) 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 attributes : CST.attr_decl option = match inline with 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 -> 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 -> match hd with | 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) 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 [] -> ok @@ CST.Name struct_name | lst -> @@ -559,7 +560,7 @@ and decompile_to_selection : AST.access -> (CST.selection, _) result = fun acces "Can't decompile access_map to selection" 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 param_const : CST.param_const = {kwd_const=rg;var;param_type} 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 -> let%bind cases = match m with 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 case : _ CST.case_clause = {pattern; arrow=rg; rhs}in ok @@ [wrap case] | 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 pattern : CST.pattern = PTuple (wrap @@ par @@ tuple) in let%bind rhs = f expr in @@ -589,13 +590,13 @@ fun f m -> let%bind rhs = f match_none in let none_case : _ CST.case_clause = {pattern=PConstr (PNone rg);arrow=rg; rhs} 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 ok @@ [wrap some_case;wrap none_case] | Match_list {match_nil; match_cons} -> let (hd,tl,expr) = match_cons in - let hd = CST.PVar (decompile_variable hd) in - let tl = CST.PVar (decompile_variable tl) in + let hd = CST.PVar (decompile_variable hd.wrap_content) in + let tl = CST.PVar (decompile_variable tl.wrap_content) in let cons = (hd,[rg,tl]) in let%bind rhs = f @@ expr 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 ok @@ [wrap cons_case; wrap nil_case] | Match_variant lst -> - let aux ((c,v),e) = + let aux ((c,(v:AST.expression_variable)),e) = let AST.Constructor c = 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 pattern : CST.pattern = PConstr (PConstrApp (wrap (constr, Some tuple))) in let%bind rhs = f e in @@ -637,7 +638,7 @@ let decompile_declaration : AST.declaration Location.wrap -> (CST.declaration, _ Some attr_decl | false -> None in - let name = decompile_variable var in + let name = decompile_variable var.wrap_content in let fun_name = name in match expr.expression_content with E_lambda lambda -> diff --git a/src/passes/05-purification/compiler.ml b/src/passes/05-purification/compiler.ml index 03754c0d5..325ff757e 100644 --- a/src/passes/05-purification/compiler.ml +++ b/src/passes/05-purification/compiler.ml @@ -3,6 +3,8 @@ module I = Ast_imperative module O = Ast_sugar open Trace +let compare_var = Location.compare_content ~compare:Var.compare + let rec add_to_end (expression: O.expression) to_add = match expression.expression_content with | 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) | E_let_in {let_binder;mut=true; rhs;let_result} -> 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) else( - let free_var = if (List.mem name free_var) then free_var else name::free_var in - let expr = O.e_let_in (env,None) false false (O.e_update (O.e_variable env) [O.Access_record (Var.to_name name)] (O.e_variable name)) let_result 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.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) ) | 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) | E_let_in {let_binder;mut=true; rhs;let_result} -> 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) 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_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 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 O.e_unit () 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) 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) = - 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 let ef = List.fold_left aux (fun e -> e) free_vars in 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 then_clause' = compile_expression then_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_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 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 let cond_expr = O.e_cond condition then_clause else_clause in 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 (n,expr) = match_some 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_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 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 let match_expr = O.e_matching matchee (O.Match_option {match_none; match_some=(n,expr)}) in 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 (hd,tl,expr) = match_cons 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_cons), expr) = repair_mutable_variable_in_matching expr' [hd;tl] env in let match_nil = add_to_end match_nil (O.e_variable env) in let expr = add_to_end expr (O.e_variable env) in - let 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 let match_expr = O.e_matching matchee (O.Match_list {match_nil; match_cons=(hd,tl,expr)}) in let return_expr = fun expr -> @@ -367,7 +372,7 @@ and compile_matching : I.matching -> Location.t -> (O.expression option -> O.exp else return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr')} | I.Match_variant lst -> - let env = Var.fresh ~name:"env" () in + let env = Location.wrap (Var.fresh ~name:"env" ()) in let aux fv ((c,n),expr) = let%bind expr = compile_expression expr 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 ok (free_vars::fv,((c,n), case_clause, case_clause')) 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 ( 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 @@ -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) and compile_while I.{condition;body} = - let env_rec = Var.fresh ~name:"env_rec" () in - let binder = Var.fresh ~name:"binder" () in + let env_rec = Location.wrap @@ Var.fresh ~name:"env_rec" () in + let binder = Location.wrap @@ Var.fresh ~name:"binder" () in let%bind cond = compile_expression condition in let ctrl = @@ -416,7 +421,7 @@ and compile_while I.{condition;body} = let for_body = add_to_end for_body ctrl in 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 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 @@ -438,7 +443,7 @@ and compile_while I.{condition;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 *) 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 @@ -455,7 +460,7 @@ and compile_for I.{binder;start;final;increment;body} = let for_body = add_to_end for_body ctrl in 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 (* 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 and compile_for_each I.{binder;collection;collection_type; body} = - let env_rec = Var.fresh ~name:"env_rec" () in - let args = Var.fresh ~name:"args" () in + let env_rec = Location.wrap @@ Var.fresh ~name:"env_rec" () in + let args = Location.wrap @@ Var.fresh ~name:"args" () in let%bind element_names = ok @@ match snd binder with | 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%bind collect = compile_expression collection in 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 let restore = fun expr -> List.fold_right aux free_vars expr in let restore = match collection_type with diff --git a/src/passes/07-desugaring/compiler.ml b/src/passes/07-desugaring/compiler.ml index e9201713e..b2582a1e4 100644 --- a/src/passes/07-desugaring/compiler.ml +++ b/src/passes/07-desugaring/compiler.ml @@ -171,11 +171,12 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r let%bind matchee = compile_expression condition in let%bind match_true = compile_expression then_clause in let%bind match_false = compile_expression else_clause in - return @@ O.E_matching {matchee; cases=Match_variant ([((Constructor "true", Var.of_name "_"),match_true);((Constructor "false", Var.of_name "_"), match_false)])} + 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} -> let%bind expr1 = compile_expression expr1 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_tuple t -> let aux (i,acc) el = diff --git a/src/passes/07-desugaring/decompiler.ml b/src/passes/07-desugaring/decompiler.ml index 200bedeae..5a96ff2dc 100644 --- a/src/passes/07-desugaring/decompiler.ml +++ b/src/passes/07-desugaring/decompiler.ml @@ -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 lambda = decompile_lambda lambda in 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 expr2 = decompile_expression expr2 in return @@ I.E_sequence {expr1;expr2} diff --git a/src/passes/09-typing/08-typer-old/typer.ml b/src/passes/09-typing/08-typer-old/typer.ml index 93292e5af..5f6e9afd5 100644 --- a/src/passes/09-typing/08-typer-old/typer.ml +++ b/src/passes/09-typing/08-typer-old/typer.ml @@ -743,7 +743,7 @@ and type_lambda e { match result.content with | I.E_let_in li -> ( 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 | Some ty -> ok ty | None -> default_action li.rhs () diff --git a/src/passes/10-self_ast_typed/helpers.ml b/src/passes/10-self_ast_typed/helpers.ml index d66c32c98..9444ef354 100644 --- a/src/passes/10-self_ast_typed/helpers.ml +++ b/src/passes/10-self_ast_typed/helpers.ml @@ -256,12 +256,12 @@ type contract_type = { 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 | 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 else None | Declaration_type _ -> None in - let main_decl_opt = List.find_map aux @@ List.rev program in + let main_decl_opt = List.find_map aux @@ List.rev program in let%bind main_decl = trace_option (corner_case ("Entrypoint '"^main_fname^"' does not exist")) @@ main_decl_opt diff --git a/src/passes/10-self_ast_typed/michelson_layout.ml b/src/passes/10-self_ast_typed/michelson_layout.ml index 1bf47bee9..3653df48a 100644 --- a/src/passes/10-self_ast_typed/michelson_layout.ml +++ b/src/passes/10-self_ast_typed/michelson_layout.ml @@ -23,7 +23,7 @@ let constructor (constructor:constructor') (element:expression) (t:type_expressi } 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 ; type_expression = t ; } @@ -151,20 +151,20 @@ let rec from_right_comb_or (to_convert:expression) (e:expression) (matchee_t,bod | [m] , bl::br::[] -> let cases = [ { constructor = Constructor "M_left" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = bl } ; { constructor = Constructor "M_right" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = br } ] in ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) | m::mtl , b::btl -> let%bind body = from_right_comb_or to_convert e (mtl,btl) in let cases = [ { constructor = Constructor "M_left" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = b } ; { constructor = Constructor "M_right" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body } ] in ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) | _ -> 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::[] -> let cases = [ { constructor = Constructor "M_right" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = bl } ; { constructor = Constructor "M_left" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = br } ] in ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) | m::mtl , b::btl -> let%bind body = from_left_comb_or to_convert e (mtl,btl) in let cases = [ { constructor = Constructor "M_right" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body = b } ; { constructor = Constructor "M_left" ; - pattern = Var.of_name "x"; + pattern = Location.wrap @@ Var.of_name "x"; body } ] in ok @@ matching e m (Match_variant { cases ; tv = to_convert.type_expression }) | _ -> 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 bodies = left_comb_variant_combination e dst_cmap src_kvl in 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 } in 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 bodies = right_comb_variant_combination e dst_cmap src_kvl in 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 } in let cases = Match_variant { diff --git a/src/passes/10-self_ast_typed/tail_recursion.ml b/src/passes/10-self_ast_typed/tail_recursion.ml index a0a4cbe46..8de31b56f 100644 --- a/src/passes/10-self_ast_typed/tail_recursion.ml +++ b/src/passes/10-self_ast_typed/tail_recursion.ml @@ -2,6 +2,8 @@ open Errors open Ast_typed 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 -> match e.expression_content with | E_literal _ -> ok () @@ -10,7 +12,7 @@ let rec check_recursive_call : expression_variable -> bool -> expression -> (uni ok () | E_variable v -> ( 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 () ) | E_application {lamb;args} -> diff --git a/src/passes/11-interpreter/interpreter.ml b/src/passes/11-interpreter/interpreter.ml index 9570a3993..b875613e2 100644 --- a/src/passes/11-interpreter/interpreter.ml +++ b/src/passes/11-interpreter/interpreter.ml @@ -380,7 +380,7 @@ let eval : Ast_typed.program -> (string , _) result = ok (V_Failure s) (*TODO This TRY-CATCH is here until we properly implement effects*) 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 ok @@ (pp',top_env') | Ast_typed.Declaration_type _ -> diff --git a/src/passes/11-spilling/compiler.ml b/src/passes/11-spilling/compiler.ml index 8dca424af..9d0f560a8 100644 --- a/src/passes/11-spilling/compiler.ml +++ b/src/passes/11-spilling/compiler.ml @@ -406,7 +406,7 @@ and compile_expression (ae:AST.expression) : (expression , spilling_error) resul let%bind f' = compile_expression f in let%bind input' = compile_type input 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 ok ((binder , input'), application) in @@ -507,13 +507,13 @@ and compile_expression (ae:AST.expression) : (expression , spilling_error) resul | ((`Node (a , b)) , tv) -> let%bind a' = 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 ok ((left_var , a_ty) , e) in let%bind b' = 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 ok ((right_var , b_ty) , e) 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 -> match e.expression_content with 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 rhs = compile_expression li.rhs 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 | E_application {lamb;args} -> ( 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 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) -> let%bind a' = 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 ok ((left_var , a_ty) , e) in let%bind b' = 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 ok ((right_var , b_ty) , e) in diff --git a/src/passes/12-self_mini_c/self_mini_c.ml b/src/passes/12-self_mini_c/self_mini_c.ml index 6ce39bddd..bf9397350 100644 --- a/src/passes/12-self_mini_c/self_mini_c.ml +++ b/src/passes/12-self_mini_c/self_mini_c.ml @@ -181,7 +181,7 @@ let eta : bool ref -> expression -> expression = { content = E_constant {cons_name = C_CDR; arguments = [ e2 ]} ; type_expression = _ }]} -> (match (e1.content, e2.content) with | E_variable x1, E_variable x2 -> - if Var.equal x1 x2 + if Var.equal x1.wrap_content x2.wrap_content then (changed := true; { e with content = e1.content }) diff --git a/src/passes/12-self_mini_c/subst.ml b/src/passes/12-self_mini_c/subst.ml index 3fb4aabe5..faa376a13 100644 --- a/src/passes/12-self_mini_c/subst.ml +++ b/src/passes/12-self_mini_c/subst.ml @@ -20,8 +20,8 @@ let rec replace : expression -> var_name -> var_name -> expression = fun e x y -> let replace e = replace e x y in let return content = { e with content } in - let replace_var v = - if Var.equal v x + let replace_var (v:var_name) = + if Var.equal v.wrap_content x.wrap_content then y else v in 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 = fun ~body ~x ~expr -> 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 Var.equal x y + if Var.equal x.wrap_content y.wrap_content then (y, expr') (* else, if no capture, subst in binder *) else if not (Free_variables.mem y (Free_variables.expression [] expr)) then (y, self expr') (* else, avoid capture and subst in binder *) 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 (fresh, self new_body) in (* 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 match body.content with | E_variable x' -> - if x' = x + if Location.equal_content ~equal:Var.equal x' x then expr else return_id | E_closure { binder; body } -> ( @@ -202,16 +202,16 @@ let%expect_test _ = let dummy_type = Expression.make_t @@ T_base TB_unit 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" PP.expression body - Var.pp x + Var.pp x.wrap_content PP.expression expr PP.expression (subst_expression ~body ~x ~expr) in - let x = Var.of_name "x" in - let y = Var.of_name "y" in - let z = Var.of_name "z" in + let x = Location.wrap @@ Var.of_name "x" in + let y = Location.wrap @@ Var.of_name "y" in + let z = Location.wrap @@ Var.of_name "z" in let var x = wrap (E_variable x) in let app f x = wrap (E_application (f, x)) in @@ -411,7 +411,7 @@ let%expect_test _ = (* old bug *) Var.reset_counter () ; - let y0 = Var.fresh ~name:"y" () in + let y0 = Location.wrap @@ Var.fresh ~name:"y" () in show_subst ~body:(lam y (lam y0 (app (var x) (app (var y) (var y0))))) ~x:x diff --git a/src/passes/13-stacking/compiler_environment.ml b/src/passes/13-stacking/compiler_environment.ml index c561223fe..bf92c6620 100644 --- a/src/passes/13-stacking/compiler_environment.ml +++ b/src/passes/13-stacking/compiler_environment.ml @@ -31,8 +31,9 @@ let pack_closure : environment -> selector -> (michelson, stacking_error) result let e_lst = let e_lst = Environment.to_list e in let aux selector (s , _) = - match List.mem ~compare:Var.compare s selector with - | true -> List.remove_element ~compare:Var.compare s selector , true + let var_compare = fun (a:var_name) (b:var_name) -> Var.compare a.wrap_content b.wrap_content in + match List.mem ~compare:var_compare s selector with + | true -> List.remove_element ~compare:var_compare s selector , true | false -> selector , false in let e_lst' = List.fold_map_right aux lst e_lst in let e_lst'' = List.combine e_lst e_lst' in diff --git a/src/passes/13-stacking/compiler_program.ml b/src/passes/13-stacking/compiler_program.ml index 670fdd4bd..2727ed50a 100644 --- a/src/passes/13-stacking/compiler_program.ml +++ b/src/passes/13-stacking/compiler_program.ml @@ -226,7 +226,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac ) | E_application (f , arg) -> ( 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 return @@ seq [ arg ; @@ -256,7 +256,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac PP.expression expr Michelson.pp expr_code 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 ok (code, env) 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' = translate_expression 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 body' = translate_expression body (Environment.add v env) in let code = seq [ @@ -417,7 +417,7 @@ and translate_expression (expr:expression) (env:environment) : (michelson , stac | E_record_update (record, path, expr) -> ( 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%bind expr' = translate_expression expr env' in let modify_code = diff --git a/src/passes/13-stacking/errors.ml b/src/passes/13-stacking/errors.ml index 0c7a297f7..14030d770 100644 --- a/src/passes/13-stacking/errors.ml +++ b/src/passes/13-stacking/errors.ml @@ -46,7 +46,7 @@ let rec error_ppformat : display_format:string display_format -> match a with | `Stacking_get_environment (var,env) -> 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 Format.pp_print_string f s ; | `Stacking_corner_case (loc,msg) -> @@ -59,7 +59,7 @@ let rec error_ppformat : display_format:string display_format -> Format.pp_print_string f s ; | `Stacking_expression_tracer (e,ty,err) -> Format.fprintf f - "@[compiling expression@%a of type %a@%a]" + "@[compiling expression %a@ of type %a@ %a]" Mini_c.PP.expression e Mini_c.PP.type_variable ty (error_ppformat ~display_format) err @@ -101,7 +101,7 @@ let rec error_jsonformat : stacking_error -> J.t = fun a -> in match a with | `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 content = `Assoc [ ("message", `String "failed to get var from environment"); diff --git a/src/stages/2-ast_imperative/PP.ml b/src/stages/2-ast_imperative/PP.ml index 0bb99ad44..0f5c5ad4a 100644 --- a/src/stages/2-ast_imperative/PP.ml +++ b/src/stages/2-ast_imperative/PP.ml @@ -26,7 +26,7 @@ let record_sep value sep ppf (m : 'a label_map) = fprintf ppf "%a" (list_sep new_pp sep) lst 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' : (formatter -> type_expression -> unit) diff --git a/src/stages/2-ast_imperative/combinators.ml b/src/stages/2-ast_imperative/combinators.ml index d52a4bdef..e2e3e4816 100644 --- a/src/stages/2-ast_imperative/combinators.ml +++ b/src/stages/2-ast_imperative/combinators.ml @@ -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_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_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_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_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_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_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_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_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_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_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 - 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 - Match_variant lst + Match_variant lst *) let e_record ?loc map = make_e ?loc @@ E_record map 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_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 -> diff --git a/src/stages/2-ast_imperative/combinators.mli b/src/stages/2-ast_imperative/combinators.mli index c03b88de5..bf8e77334 100644 --- a/src/stages/2-ast_imperative/combinators.mli +++ b/src/stages/2-ast_imperative/combinators.mli @@ -87,21 +87,21 @@ val e_variable_ez : ?loc:Location.t -> string -> 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_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_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_constructor : ?loc:Location.t -> string -> expression -> 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_record : ?loc:Location.t -> expression -> (label * expression_variable) list -> type_expression list option -> expression -> expression val e_matching_tuple : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression val e_matching_variable: ?loc:Location.t -> expression -> expression_variable -> type_expression option -> expression -> expression -val e_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_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_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_each_ez : ?loc:Location.t -> string * string option -> expression -> collect_type -> 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 make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression diff --git a/src/stages/3-ast_sugar/PP.ml b/src/stages/3-ast_sugar/PP.ml index 99cf01d3f..9bcae3904 100644 --- a/src/stages/3-ast_sugar/PP.ml +++ b/src/stages/3-ast_sugar/PP.ml @@ -22,7 +22,7 @@ let record_sep_t value sep ppf (m : 'a label_map) = 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' : (formatter -> type_expression -> unit) diff --git a/src/stages/4-ast_core/PP.ml b/src/stages/4-ast_core/PP.ml index b93108f93..3f368e21d 100644 --- a/src/stages/4-ast_core/PP.ml +++ b/src/stages/4-ast_core/PP.ml @@ -87,7 +87,7 @@ and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_ fprintf ppf "(type_operator: %s)" s 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) = diff --git a/src/stages/4-ast_core/combinators.ml b/src/stages/4-ast_core/combinators.ml index 46debd9ab..a46d43f7f 100644 --- a/src/stages/4-ast_core/combinators.ml +++ b/src/stages/4-ast_core/combinators.ml @@ -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 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_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) diff --git a/src/stages/5-ast_typed/PP.ml b/src/stages/5-ast_typed/PP.ml index 605b44be5..4dd7c4943 100644 --- a/src/stages/5-ast_typed/PP.ml +++ b/src/stages/5-ast_typed/PP.ml @@ -258,7 +258,7 @@ and type_operator : (* end include Stage_common.PP *) 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) = diff --git a/src/stages/5-ast_typed/PP_generic.ml b/src/stages/5-ast_typed/PP_generic.ml index 662d41cc6..d14611b86 100644 --- a/src/stages/5-ast_typed/PP_generic.ml +++ b/src/stages/5-ast_typed/PP_generic.ml @@ -64,7 +64,7 @@ module M = struct bytes = (fun _visitor NoState _bytes -> fprintf ppf "bytes...") ; unit = (fun _visitor NoState () -> fprintf ppf "()") ; 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) ; location = (fun _visitor NoState loc -> fprintf ppf "%a" Location.pp loc) ; label = (fun _visitor NoState (Label lbl) -> fprintf ppf "Label %s" lbl) ; diff --git a/src/stages/5-ast_typed/PP_json.ml b/src/stages/5-ast_typed/PP_json.ml index 18c6b8baf..53d09100f 100644 --- a/src/stages/5-ast_typed/PP_json.ml +++ b/src/stages/5-ast_typed/PP_json.ml @@ -31,7 +31,7 @@ module M = struct bytes = (fun _visitor NoState bytes -> `String (Bytes.to_string bytes)) ; unit = (fun _visitor NoState () -> `String "unit" ) ; 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] ) ; location = (fun _visitor NoState loc -> `String (asprintf "%a" Location.pp loc) ) ; (*TODO*) label = (fun _visitor NoState (Label lbl) -> `Assoc ["label" , `String lbl] ) ; diff --git a/src/stages/5-ast_typed/combinators.ml b/src/stages/5-ast_typed/combinators.ml index bb8a6069b..65a1647fb 100644 --- a/src/stages/5-ast_typed/combinators.ml +++ b/src/stages/5-ast_typed/combinators.ml @@ -335,7 +335,7 @@ let get_a_record_accessor = fun t -> let get_declaration_by_name : program -> string -> declaration option = fun p name -> let aux : declaration -> bool = fun declaration -> 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 in List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/stages/5-ast_typed/compare_generic.ml b/src/stages/5-ast_typed/compare_generic.ml index a1be2e6ed..c2a350c3f 100644 --- a/src/stages/5-ast_typed/compare_generic.ml +++ b/src/stages/5-ast_typed/compare_generic.ml @@ -146,7 +146,7 @@ module M = struct | (Bool a, Bool b) -> (Pervasives.compare : bool -> bool -> int) a b | (Bytes a, Bytes b) -> Bytes.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 | (Label' a, Label' b) -> String.compare a b | (Ligo_string a, Ligo_string b) -> Simple_utils.Ligo_string.compare a b diff --git a/src/stages/5-ast_typed/environment.ml b/src/stages/5-ast_typed/environment.ml index df9706451..0ff130bc5 100644 --- a/src/stages/5-ast_typed/environment.ml +++ b/src/stages/5-ast_typed/environment.ml @@ -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. *) let get_opt : expression_variable -> t -> element option = fun k x -> 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 -> Option.bind (fun {type_variable=_ ; type_} -> Some type_) @@ List.find_opt (fun {type_variable ; type_=_} -> Var.equal type_variable k) (get_type_environment x) diff --git a/src/stages/5-ast_typed/misc.ml b/src/stages/5-ast_typed/misc.ml index d899f19b1..fd9a99eaa 100644 --- a/src/stages/5-ast_typed/misc.ml +++ b/src/stages/5-ast_typed/misc.ml @@ -3,7 +3,8 @@ open Types module Free_variables = struct 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 union : bindings -> bindings -> bindings = (@) let unions : bindings list -> bindings = List.concat @@ -219,7 +220,7 @@ let get_entry (lst : program) (name : string) : expression option = let aux x = match Location.unwrap x with | 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 else None ) @@ -229,7 +230,7 @@ let get_entry (lst : program) (name : string) : expression option = let equal_variables a b : bool = 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 let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = { diff --git a/src/stages/5-ast_typed/misc_smart.ml b/src/stages/5-ast_typed/misc_smart.ml index 92a964586..8fae1c653 100644 --- a/src/stages/5-ast_typed/misc_smart.ml +++ b/src/stages/5-ast_typed/misc_smart.ml @@ -6,7 +6,8 @@ open Misc module Captured_variables = struct 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 union : bindings -> bindings -> bindings = (@) let unions : bindings list -> bindings = List.concat diff --git a/src/stages/6-mini_c/PP.ml b/src/stages/6-mini_c/PP.ml index 568c20af2..4de188688 100644 --- a/src/stages/6-mini_c/PP.ml +++ b/src/stages/6-mini_c/PP.ml @@ -24,7 +24,7 @@ and annotated ppf : type_expression annotated -> _ = function | (None, a) -> type_variable ppf a 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) = 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 | E_skip -> fprintf ppf "skip" | 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_constant c -> fprintf ppf "@[%a@[(%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)) -> fprintf ppf "@[match %a with@ @[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]" - expression c expression n Var.pp name 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 + 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.wrap_content Var.pp tl_name.wrap_content expression cons | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> fprintf ppf "@[match %a with@ @[| 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_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) -> - 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) -> - 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) -> 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) = fprintf ppf "@[fun %a ->@ (%a)@]" - Var.pp binder + Var.pp binder.wrap_content expression body and option_inline ppf inline = @@ -144,7 +146,7 @@ and option_inline ppf inline = else 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 @@ -278,11 +280,13 @@ let%expect_test _ = let pp = expression_content Format.std_formatter 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 - 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{| 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{| fun z -> (z) |}] diff --git a/src/stages/6-mini_c/combinators_smart.ml b/src/stages/6-mini_c/combinators_smart.ml index 7eece2a3b..54cd028a1 100644 --- a/src/stages/6-mini_c/combinators_smart.ml +++ b/src/stages/6-mini_c/combinators_smart.ml @@ -3,4 +3,4 @@ open Combinators let basic_int_quote_env : environment = 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 diff --git a/src/stages/6-mini_c/environment.ml b/src/stages/6-mini_c/environment.ml index 36a79d4e0..0ea472a5e 100644 --- a/src/stages/6-mini_c/environment.ml +++ b/src/stages/6-mini_c/environment.ml @@ -18,15 +18,18 @@ module Environment (* : ENVIRONMENT *) = struct type element = environment_element 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 add : element -> t -> t = List.cons 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 -> match get_opt s t with | None -> false | 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 to_list : t -> element list = fun x -> x let get_names : t -> expression_variable list = List.map fst @@ -36,8 +39,8 @@ module Environment (* : ENVIRONMENT *) = struct let e_lst = let e_lst = to_list env in let aux selector (s , _) = - match List.mem ~compare:Var.compare s selector with - | true -> List.remove_element ~compare:Var.compare s selector , keep + match List.mem ~compare:compare_var s selector with + | true -> List.remove_element ~compare:compare_var s selector , keep | false -> selector , not keep in let e_lst' = if rev = keep diff --git a/src/stages/6-mini_c/misc.ml b/src/stages/6-mini_c/misc.ml index 17a3a7d0c..dbb3ea366 100644 --- a/src/stages/6-mini_c/misc.ml +++ b/src/stages/6-mini_c/misc.ml @@ -4,11 +4,13 @@ open Combinators module Free_variables = struct 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 mem_count : expression_variable -> bindings -> int = 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 unions : bindings list -> bindings = List.concat let empty : bindings = [] @@ -98,8 +100,8 @@ end let get_entry (lst : program) (name : string) : (expression * int) option = let entry_expression = let aux x = - let (((decl_name , _, decl_expr) , _)) = x in - if (Var.equal decl_name (Var.of_name name)) + let ((((decl_name:expression_variable) , _, decl_expr) , _)) = x in + if (Var.equal decl_name.wrap_content (Var.of_name name)) then Some decl_expr else None in @@ -109,8 +111,8 @@ let get_entry (lst : program) (name : string) : (expression * int) option = | Some exp -> let entry_index = let aux x = - let (((decl_name , _, _) , _)) = x in - Var.equal decl_name (Var.of_name name) + let ((((decl_name:expression_variable) , _, _) , _)) = x in + Var.equal decl_name.wrap_content (Var.of_name name) in (List.length lst) - (List.find_index aux (List.rev lst)) - 1 in diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index aad02eeeb..53fbc61e8 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -1,5 +1,5 @@ type expression_ -and expression_variable = expression_ Var.t +and expression_variable = expression_ Var.t Location.wrap type type_ and type_variable = type_ Var.t diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml index 03a410b38..343093382 100644 --- a/src/stages/ligo_interpreter/PP.ml +++ b/src/stages/ligo_interpreter/PP.ml @@ -34,7 +34,7 @@ let rec pp_value : value -> string = function let pp_env : env -> unit = fun env -> let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in 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 let () = Format.printf "\n}\n" in () diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml index eeb7ec1c3..7718a24ae 100644 --- a/src/stages/ligo_interpreter/types.ml +++ b/src/stages/ligo_interpreter/types.ml @@ -4,7 +4,7 @@ include Ast_typed.Types module Env = Map.Make( struct 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 ) diff --git a/src/test/hash_lock_tests.ml b/src/test/hash_lock_tests.ml index ba8221e1f..7d4e70d06 100644 --- a/src/test/hash_lock_tests.ml +++ b/src/test/hash_lock_tests.ml @@ -45,7 +45,7 @@ let (first_committer , first_contract) = let empty_op_list = (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 ()))) empty_op_list diff --git a/src/test/multisig_tests.ml b/src/test/multisig_tests.ml index df3a42887..953415bbc 100644 --- a/src/test/multisig_tests.ml +++ b/src/test/multisig_tests.ml @@ -45,7 +45,7 @@ let init_storage threshold counter pkeys = let empty_op_list = (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 ()))) empty_op_list let chain_id_zero = e_chain_id @@ Tezos_crypto.Base58.simple_encode diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index 6c230881e..3f9f93378 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -28,12 +28,12 @@ open Ast_imperative let empty_op_list = (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 ()))) 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 ()))) - ( 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 withdraw_param = e_constructor "Withdraw" empty_message diff --git a/src/test/pledge_tests.ml b/src/test/pledge_tests.ml index 6f6b371ea..8132db246 100644 --- a/src/test/pledge_tests.ml +++ b/src/test/pledge_tests.ml @@ -39,7 +39,7 @@ let (stranger_addr , stranger_contract) = let empty_op_list = (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 ()))) empty_op_list diff --git a/src/test/replaceable_id_tests.ml b/src/test/replaceable_id_tests.ml index 771b439a7..05a90a4d7 100644 --- a/src/test/replaceable_id_tests.ml +++ b/src/test/replaceable_id_tests.ml @@ -28,7 +28,7 @@ open Ast_imperative let empty_op_list = (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 ()))) empty_op_list diff --git a/src/test/time_lock_repeat_tests.ml b/src/test/time_lock_repeat_tests.ml index 06061c25d..b30354b42 100644 --- a/src/test/time_lock_repeat_tests.ml +++ b/src/test/time_lock_repeat_tests.ml @@ -28,7 +28,7 @@ let compile_main () = let empty_op_list = (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 ()))) empty_op_list diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml index 9dd75b606..76037325a 100644 --- a/src/test/time_lock_tests.ml +++ b/src/test/time_lock_tests.ml @@ -29,7 +29,7 @@ open Ast_imperative let empty_op_list = (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 ()))) empty_op_list diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index ca897fcf4..9466230ea 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -47,7 +47,7 @@ module TestExpressions = struct let lambda () : (unit, _) result = 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 ()) ()) let tuple () : (unit, _) result = diff --git a/vendors/ligo-utils/simple-utils/location.ml b/vendors/ligo-utils/simple-utils/location.ml index 96c361f3d..8febf4698 100644 --- a/vendors/ligo-utils/simple-utils/location.ml +++ b/vendors/ligo-utils/simple-utils/location.ml @@ -46,6 +46,12 @@ let compare_wrap ~compare:compare_content { wrap_content = wca ; location = la } | 0 -> compare la lb | 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 get_location x = x.location let unwrap { wrap_content ; _ } = wrap_content