From 85dc95dc7bc02a31e07c5e8ead2c965853784ded Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 19 May 2020 18:53:20 +0200 Subject: [PATCH] solve to bug with location --- src/passes/2-concrete_to_imperative/cameligo.ml | 9 +++++---- .../4-imperative_to_sugar/imperative_to_sugar.ml | 14 +++++++------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index 34e34ed37..405b3fe74 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -218,7 +218,8 @@ let rec typed_pattern_to_typed_vars : Raw.pattern -> _ = fun pattern -> let (p,t) = pt.value.pattern,pt.value.type_expr in let%bind p = tuple_pattern_to_vars p in let%bind t = compile_type_expression t in - ok @@ (p,t) + let l = Location.lift pt.region in + ok @@ (p,t,l) | other -> (fail @@ wrong_pattern "parenthetical or type annotation" other) and unpar_pattern : Raw.pattern -> Raw.pattern = function @@ -452,7 +453,7 @@ let rec compile_expression : let f_args = nseq_to_list (binders) in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in - let aux acc ty = Option.map (t_function (snd ty)) acc in + let aux acc (_,ty,loc) = Option.map (t_function ~loc ty) acc in ok @@ (List.fold_right' aux lhs_type' ty) | _ -> ok None ) @@ -928,7 +929,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu } in let f_args = nseq_to_list (param1,others) in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in - let aux acc ty = Option.map (t_function (snd ty)) acc in + let aux acc (_,ty,loc) = Option.map (t_function ~loc ty) acc in ok (Raw.EFun {region; value=fun_},List.fold_right' aux lhs_type' ty) in let%bind rhs' = compile_expression let_rhs in @@ -938,7 +939,7 @@ and compile_declaration : Raw.declaration -> declaration Location.wrap list resu let f_args = nseq_to_list (binders) in let%bind lhs_type' = bind_map_option (fun x -> compile_type_expression (snd x)) lhs_type in let%bind ty = bind_map_list typed_pattern_to_typed_vars f_args in - let aux acc ty = Option.map (t_function (snd ty)) acc in + let aux acc (_,ty,loc) = Option.map (t_function ~loc ty) acc in ok @@ (List.fold_right' aux lhs_type' ty) | _ -> ok None ) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 9365932f4..224c2de10 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -253,7 +253,7 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind element = compile_expression element in return @@ O.e_constructor ~loc constructor element | I.E_matching m -> - let%bind m = compile_matching m in + let%bind m = compile_matching m loc in ok @@ m | I.E_record record -> let record = I.LMap.to_kv_list record in @@ -385,8 +385,8 @@ and compile_lambda : I.lambda -> O.lambda result = let%bind result = compile_expression result in ok @@ O.{binder;input_type;output_type;result} -and compile_matching : I.matching -> (O.expression option -> O.expression) result = - fun {matchee;cases} -> +and compile_matching : I.matching -> Location.t -> (O.expression option -> O.expression) result = + fun {matchee;cases} loc -> let return expr = ok @@ function | None -> expr | Some e -> O.e_sequence expr e @@ -412,7 +412,7 @@ and compile_matching : I.matching -> (O.expression option -> O.expression) resul in ok @@ restore_mutable_variable return_expr free_vars env else - return @@ O.e_matching matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)} + return @@ O.e_matching ~loc matchee @@ O.Match_option {match_none=match_none'; match_some=(n,expr',tv)} | I.Match_list {match_nil;match_cons} -> let%bind match_nil' = compile_expression match_nil in let (hd,tl,expr,tv) = match_cons in @@ -432,10 +432,10 @@ and compile_matching : I.matching -> (O.expression option -> O.expression) resul in ok @@ restore_mutable_variable return_expr free_vars env else - return @@ O.e_matching matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)} + return @@ O.e_matching ~loc matchee @@ O.Match_list {match_nil=match_nil'; match_cons=(hd,tl,expr',tv)} | I.Match_tuple ((lst,expr), tv) -> let%bind expr = compile_expression expr in - return @@ O.e_matching matchee @@ O.Match_tuple ((lst,expr), tv) + return @@ O.e_matching ~loc matchee @@ O.Match_tuple ((lst,expr), tv) | I.Match_variant (lst,tv) -> let env = Var.fresh () in let aux fv ((c,n),expr) = @@ -448,7 +448,7 @@ and compile_matching : I.matching -> (O.expression option -> O.expression) resul let free_vars = List.sort_uniq Var.compare @@ List.concat fv in if (List.length free_vars == 0) then ( let cases = List.map (fun case -> let (a,_,b) = case in (a,b)) cases in - return @@ O.e_matching matchee @@ O.Match_variant (cases,tv) + return @@ O.e_matching ~loc matchee @@ O.Match_variant (cases,tv) ) else ( let cases = List.map (fun case -> let (a,b,_) = case in (a,b)) cases in let match_expr = O.e_matching matchee @@ O.Match_variant (cases,tv) in