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

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

Browse Source
This commit is contained in:
Christian Rinderknecht 2020-07-01 20:49:05 +02:00
commit 6c50ec0ed1
51 changed files with 299 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/main/compile/of_core.ml
View File

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

2
src/main/compile/of_imperative.ml
View File

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

2
src/main/compile/of_sugar.ml
View File

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

58
src/passes/03-tree_abstraction/cameligo/compiler.ml
View File

@ -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,8 +917,11 @@ 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) ] ->
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 = (Var.of_name some_var, some_expr);
match_some = (proj, some_expr);
match_none = none_expr }
| _ -> fail @@ corner_case "bad option pattern"
in bind_or (as_option () , as_variant ())

30
src/passes/03-tree_abstraction/cameligo/decompiler.ml
View File

@ -98,7 +98,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let get_e_variable : AST.expression -> _ result = fun expr ->
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 ->

90
src/passes/03-tree_abstraction/pascaligo/compiler.ml
View File

@ -282,14 +282,14 @@ 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
@ -299,15 +299,15 @@ let rec compile_expression : CST.expr -> (AST.expr , abs_error) result = fun e -
let%bind body = compile_expression func.return in
let (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,12 +775,12 @@ 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)
)
@ -772,11 +789,11 @@ and compile_fun_decl ({kwd_recursive; fun_name; param; ret_type; return=r; attri
let%bind func = match kwd_recursive with
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

39
src/passes/03-tree_abstraction/pascaligo/decompiler.ml
View File

@ -99,7 +99,7 @@ let rec decompile_type_expr : AST.type_expression -> _ result = fun te ->
let get_e_variable : AST.expression -> _ result = fun expr ->
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 ->

53
src/passes/05-purification/compiler.ml
View File

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

5
src/passes/07-desugaring/compiler.ml
View File

@ -171,11 +171,12 @@ let rec compile_expression : I.expression -> (O.expression , desugaring_error) r
let%bind matchee = compile_expression condition in
let%bind 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 =

4
src/passes/07-desugaring/decompiler.ml
View File

@ -66,7 +66,9 @@ let rec decompile_expression : O.expression -> (I.expression, desugaring_error)
let%bind fun_type = decompile_type_expression fun_type in
let%bind 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}

2
src/passes/09-typing/08-typer-old/typer.ml
View File

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

2
src/passes/10-self_ast_typed/helpers.ml
View File

@ -256,7 +256,7 @@ type contract_type = {
let fetch_contract_type : string -> program -> (contract_type, self_ast_typed_error) result = fun main_fname program ->
let 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

22
src/passes/10-self_ast_typed/michelson_layout.ml
View File

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

4
src/passes/10-self_ast_typed/tail_recursion.ml
View File

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

2
src/passes/11-interpreter/interpreter.ml
View File

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

14
src/passes/11-spilling/compiler.ml
View File

@ -406,7 +406,7 @@ and compile_expression (ae:AST.expression) : (expression , spilling_error) resul
let%bind f' = compile_expression f in
let%bind 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

2
src/passes/12-self_mini_c/self_mini_c.ml
View File

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

24
src/passes/12-self_mini_c/subst.ml
View File

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

5
src/passes/13-stacking/compiler_environment.ml
View File

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

8
src/passes/13-stacking/compiler_program.ml
View File

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

6
src/passes/13-stacking/errors.ml
View File

@ -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
"@[<hv>compiling expression@%a of type %a@%a]"
"@[<hv>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");

2
src/stages/2-ast_imperative/PP.ml
View File

@ -26,7 +26,7 @@ let record_sep value sep ppf (m : 'a label_map) =
fprintf ppf "%a" (list_sep new_pp sep) lst
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)

20
src/stages/2-ast_imperative/combinators.ml
View File

@ -100,13 +100,13 @@ let e_binop ?loc name a b = make_e ?loc @@ E_constant {cons_name = name ; argum
let e_constant ?loc name lst = make_e ?loc @@ E_constant {cons_name=name ; arguments = lst}
let e_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 ->

12
src/stages/2-ast_imperative/combinators.mli
View File

@ -87,21 +87,21 @@ val e_variable_ez : ?loc:Location.t -> string -> expression
val e_application : ?loc:Location.t -> expression -> expression -> expression
val e_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

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

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

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

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

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

@ -54,7 +54,7 @@ let t_contract ?loc ?sugar contract : type_expression = make_t ?loc ?sugar @
let make_e ?(loc = Location.generated) ?sugar content = {content; sugar; location=loc }
let 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)

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

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

2
src/stages/5-ast_typed/PP_generic.ml
View File

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

2
src/stages/5-ast_typed/PP_json.ml
View File

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

2
src/stages/5-ast_typed/combinators.ml
View File

@ -335,7 +335,7 @@ let get_a_record_accessor = fun t ->
let get_declaration_by_name : program -> string -> declaration option = fun p name ->
let 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

2
src/stages/5-ast_typed/compare_generic.ml
View File

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

2
src/stages/5-ast_typed/environment.ml
View File

@ -27,7 +27,7 @@ let add_type : type_variable -> type_expression -> t -> t = fun type_variable ty
(* TODO: generate : these are now messy, clean them up. *)
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)

7
src/stages/5-ast_typed/misc.ml
View File

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

3
src/stages/5-ast_typed/misc_smart.ml
View File

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

28
src/stages/6-mini_c/PP.ml
View File

@ -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@[<hv 1>(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments
@ -107,19 +107,21 @@ and expression_content ppf (e:expression_content) = match e with
| E_if_none (c, n, ((name, _) , s)) ->
fprintf ppf
"@[match %a with@ @[<hv>| 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@ @[<hv>| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]"
expression c Var.pp name_l expression l Var.pp name_r expression r
expression c Var.pp name_l.wrap_content expression l Var.pp name_r.wrap_content expression r
| E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b
| E_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)
|}]

2
src/stages/6-mini_c/combinators_smart.ml
View File

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

11
src/stages/6-mini_c/environment.ml
View File

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

14
src/stages/6-mini_c/misc.ml
View File

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

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

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

2
src/stages/ligo_interpreter/PP.ml
View File

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

2
src/stages/ligo_interpreter/types.ml
View File

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

2
src/test/hash_lock_tests.ml
View File

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

2
src/test/multisig_tests.ml
View File

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

6
src/test/multisig_v2_tests.ml
View File

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

2
src/test/pledge_tests.ml
View File

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

2
src/test/replaceable_id_tests.ml
View File

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

2
src/test/time_lock_repeat_tests.ml
View File

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

2
src/test/time_lock_tests.ml
View File

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

2
src/test/typer_tests.ml
View File

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

6
vendors/ligo-utils/simple-utils/location.ml vendored
View File

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