diff --git a/src/bin/expect_tests/get_scope.ml b/src/bin/expect_tests/get_scope.ml index 3bd123fcd..25c9ca893 100644 --- a/src/bin/expect_tests/get_scope.ml +++ b/src/bin/expect_tests/get_scope.ml @@ -86,20 +86,19 @@ let%expect_test _ = run_ligo_good [ "get-scope" ; gs "rec.mligo" ; "--format=dev" ] ; [%expect {| Scopes: - [ k5 j4 i3 generated2 c1 a0 ] in file "rec.mligo", line 6, characters 4-11 - [ j4 i3 generated2 c1 a0 ] in file "rec.mligo", line 5, character 4 to line 6, character 11 - [ i3 generated2 c1 a0 ] in file "rec.mligo", line 4, characters 36-49 - [ generated2 c1 a0 ] in file "rec.mligo", line 4, characters 36-49 + [ k4 j3 i2 c1 a0 ] in file "rec.mligo", line 6, characters 4-11 + [ j3 i2 c1 a0 ] in file "rec.mligo", line 5, character 4 to line 6, character 11 + [ i2 c1 a0 ] in file "rec.mligo", line 4, characters 36-49 + [ c1 a0 ] in file "rec.mligo", line 4, characters 36-49 [ c1 a0 ] [ ] in file "rec.mligo", line 1, characters 0-9 Variable definitions: - (k5 -> k) in file "rec.mligo", line 5, characters 12-21 - (j4 -> j) - (i3 -> i) - (generated2 -> generated) in file "rec.mligo", line 4, characters 36-49 + (k4 -> k) in file "rec.mligo", line 5, characters 12-21 + (j3 -> j) + (i2 -> i) (c1 -> c) in file "rec.mligo", line 4, character 2 to line 8, character 9 - (b6 -> b) in file "rec.mligo", line 3, character 0 to line 8, character 9 + (b5 -> b) in file "rec.mligo", line 3, character 0 to line 8, character 9 (a0 -> a) in file "rec.mligo", line 1, characters 0-9 Type definitions: |} ] ; diff --git a/src/main/scopes/misc.ml b/src/main/scopes/misc.ml index bda2fc036..0e7d0aab3 100644 --- a/src/main/scopes/misc.ml +++ b/src/main/scopes/misc.ml @@ -2,25 +2,30 @@ open Trace open Types let get_binder_name : 'a Var.t -> string = fun (v: _ Var.t) -> - try Var.to_name v with _ -> "generated" + if Var.is_generated v + then "generated" + else Var.to_name v let make_def_id name i = (name ^ (string_of_int i), i+1) let add_shadowing_def : (int * _ Var.t) -> def -> def_map -> (int * def_map) = fun (i,var) def env -> - let name = get_binder_name var in - let (definition_id,i) = make_def_id name i in - let shadow = Def_map.filter - (fun _ s_def -> match def, s_def with - | Variable _ , Variable _ | Type _ , Type _ -> - not @@ String.equal (get_def_name s_def) name - | _ -> true ) - env in - let env = Def_map.add definition_id def shadow in - (i,env) + if Var.is_generated var then (i,env) + else + let name = get_binder_name var in + let (definition_id,i) = make_def_id name i in + let shadow = Def_map.filter + (fun _ s_def -> match def, s_def with + | Variable _ , Variable _ | Type _ , Type _ -> + not @@ String.equal (get_def_name s_def) name + | _ -> true ) + env in + let env = Def_map.add definition_id def shadow in + (i,env) -let make_v_def_from_core : with_types:bool -> string -> string -> string -> Ast_core.expression -> Location.t -> Location.t -> def = +let make_v_def_from_core : with_types:bool -> string -> string -> ('a Var.t) -> Ast_core.expression -> Location.t -> Location.t -> def = fun ~with_types source_file syntax name exp range body_range -> + let name = get_binder_name name in let t = to_option @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in let env = Ast_typed.program_environment Environment.default typed_prg in @@ -31,8 +36,9 @@ let make_v_def_from_core : with_types:bool -> string -> string -> string -> Ast_ otherwise nothing will be typed if an error occurs later in the file *) make_v_def ~with_types name t range body_range -let make_v_def_option_type : with_types:bool -> string -> string -> string -> Ast_core.type_expression option -> Location.t -> Location.t -> def = +let make_v_def_option_type : with_types:bool -> string -> string -> ('a Var.t) -> Ast_core.type_expression option -> Location.t -> Location.t -> def = fun ~with_types source_file syntax name maybe_typed range body_range -> + let name = get_binder_name name in match maybe_typed with | Some t -> let t' = to_option @@ @@ -43,9 +49,10 @@ let make_v_def_option_type : with_types:bool -> string -> string -> string -> As | None -> make_v_def ~with_types name None range body_range let make_v_def_ppx_type : - with_types:bool -> string -> string -> string -> (Ast_typed.type_expression -> Ast_typed.type_expression) -> + with_types:bool -> string -> string -> ('a Var.t) -> (Ast_typed.type_expression -> Ast_typed.type_expression) -> Ast_core.expression -> Location.t -> Location.t -> def = fun ~with_types source_file syntax name f exp range body_range -> + let name = get_binder_name name in let t = to_option @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in let env = Ast_typed.program_environment Environment.default typed_prg in diff --git a/src/main/scopes/scopes.ml b/src/main/scopes/scopes.ml index 5e9734d7e..cc9d73e00 100644 --- a/src/main/scopes/scopes.ml +++ b/src/main/scopes/scopes.ml @@ -11,26 +11,26 @@ let scopes : with_types:bool -> string -> string -> ((def_map * scopes), Main_er let rec find_scopes' = fun (i,all_defs,env,scopes,lastloc) (e : Ast_core.expression) -> match e.content with - | E_let_in { let_binder = (n,_) ; rhs ; let_result } -> ( + | E_let_in { let_binder = (fn,_) ; rhs ; let_result } -> ( match rhs.content with | E_recursive { fun_name ; fun_type ; lambda = { result;_ } } -> ( (* Note: It is not entirely true that 'fun_name' is in 'result' scope; because only tail calls are allowed *) - let def = make_v_def_option_type (get_binder_name fun_name) (Some fun_type) e.location e.location in + let def = make_v_def_option_type fun_name (Some fun_type) e.location e.location in let (i,env) = add_shadowing_def (i,fun_name) def env in find_scopes' (i,all_defs,env,scopes,result.location) result ) | _ -> ( (*TODO : n needs location and should be used bellow in union with rhs *) let (i,all_defs,_, scopes) = find_scopes' (i,all_defs,env,scopes,e.location) rhs in - let (i,env) = add_shadowing_def (i,n) (make_v_def_from_core (get_binder_name n) rhs rhs.location rhs.location) env in + let (i,env) = add_shadowing_def (i,fn) (make_v_def_from_core fn rhs rhs.location rhs.location) env in let all_defs = merge_defs env all_defs in find_scopes' (i,all_defs,env,scopes,let_result.location) let_result ) ) | E_lambda { binder ; input_type ; output_type = _ ; result } -> ( - let (i,env) = add_shadowing_def (i,binder) (make_v_def_option_type (get_binder_name binder) input_type result.location result.location) env in + let (i,env) = add_shadowing_def (i,binder) (make_v_def_option_type binder input_type result.location result.location) env in let all_defs = merge_defs env all_defs in find_scopes' (i,all_defs,env,scopes,result.location) result ) @@ -45,8 +45,8 @@ let scopes : with_types:bool -> string -> string -> ((def_map * scopes), Main_er let list_f = fun (t:Ast_typed.type_expression) -> match Ast_typed.get_t_list t with | None -> failwith "Could not get the type of a list" | Some t -> t in - let hd_def = make_v_def_ppx_type (get_binder_name hd) list_f matchee match_cons.location match_cons.location in - let tl_def = make_v_def_from_core (get_binder_name tl) matchee match_cons.location match_cons.location in + let hd_def = make_v_def_ppx_type hd list_f matchee match_cons.location match_cons.location in + let tl_def = make_v_def_from_core tl matchee match_cons.location match_cons.location in let (i,env) = add_shadowing_def (i,hd) hd_def env in let (i,env) = add_shadowing_def (i,tl) tl_def env in @@ -60,7 +60,7 @@ let scopes : with_types:bool -> string -> string -> ((def_map * scopes), Main_er let all_defs = merge_defs env all_defs in (* TODO some needs location and should be used bellow instead of match_some .. *) - let tl_def = make_v_def_from_core (get_binder_name some) matchee match_some.location match_some.location in + let tl_def = make_v_def_from_core some matchee match_some.location match_some.location in let (i,env) = add_shadowing_def (i,some) tl_def env in let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,match_some.location) match_some in @@ -74,7 +74,7 @@ let scopes : with_types:bool -> string -> string -> ((def_map * scopes), Main_er | None -> failwith "Could not get the inner type of a constructor" in (* TODO proj needs location and should be used bellow instead of match_variant .. *) - let proj_def = make_v_def_ppx_type (get_binder_name proj) proj_f matchee match_variant.location match_variant.location in + let proj_def = make_v_def_ppx_type proj proj_f matchee match_variant.location match_variant.location in let (i,env) = add_shadowing_def (i,proj) proj_def env in let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,match_variant.location) match_variant in let all_defs = merge_defs env all_defs in @@ -97,7 +97,7 @@ let scopes : with_types:bool -> string -> string -> ((def_map * scopes), Main_er match x.wrap_content with | Declaration_constant (v , _o , _i, e) -> let (i,inner_def_map,scopes) = find_scopes (i,top_def_map,scopes,x.location) e in - let def = make_v_def_from_core (get_binder_name v) e x.location e.location in + let def = make_v_def_from_core v e x.location e.location in let (i,top_def_map) = add_shadowing_def (i,v) def top_def_map in ( i, top_def_map, inner_def_map, scopes ) diff --git a/vendors/ligo-utils/simple-utils/var.ml b/vendors/ligo-utils/simple-utils/var.ml index 8aa5b3b92..045363e88 100644 --- a/vendors/ligo-utils/simple-utils/var.ml +++ b/vendors/ligo-utils/simple-utils/var.ml @@ -49,3 +49,8 @@ let fresh_like v = fresh ~name:v.name () let debug v = match v.counter with Some c -> Printf.sprintf "%s(%d)" v.name c | None -> Printf.sprintf "%s(None)" v.name + +let is_generated var = + match var.counter with + | None -> false + | Some _ -> true diff --git a/vendors/ligo-utils/simple-utils/var.mli b/vendors/ligo-utils/simple-utils/var.mli index d81d69548..bf86b9ac4 100644 --- a/vendors/ligo-utils/simple-utils/var.mli +++ b/vendors/ligo-utils/simple-utils/var.mli @@ -45,3 +45,5 @@ val fresh_like : 'a t -> 'b t val reset_counter : unit -> unit val debug : 'a t -> string + +val is_generated : 'a t -> bool \ No newline at end of file