diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 9484d8867..49f666e45 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -484,6 +484,17 @@ let transpile_expression = (Term.ret term , Term.info ~doc cmdname) +let get_scope = + let f source_file syntax display_format = + return_result ~display_format Ligo.Scopes.Formatter.scope_format @@ + Ligo.Scopes.scopes source_file syntax + in + let term = + Term.(const f $ source_file 0 $ syntax $ display_format) in + let cmdname = "get-scope" in + let doc = "Subcommand: Return the JSON encoded environment for a given file." in + (Term.ret term , Term.info ~doc cmdname) + let run ?argv () = Term.eval_choice ?argv main [ temp_ligo_interpreter ; @@ -507,5 +518,6 @@ let run ?argv () = print_mini_c ; list_declarations ; preprocess; - pretty_print + pretty_print; + get_scope; ] diff --git a/src/main/compile/of_core.ml b/src/main/compile/of_core.ml index 818e17ffb..7162b683b 100644 --- a/src/main/compile/of_core.ml +++ b/src/main/compile/of_core.ml @@ -42,3 +42,5 @@ let list_declarations (program : Ast_core.program) : string list = | Declaration_constant (var,_,_,_) -> (Var.to_name var.wrap_content)::prev | _ -> prev) [] program + +let evaluate_type (env : Ast_typed.Environment.t) (t: Ast_core.type_expression) = trace typer_tracer @@ Typer.evaluate_type env t \ No newline at end of file diff --git a/src/main/compile/utils.ml b/src/main/compile/utils.ml index 4af43dafb..488412d95 100644 --- a/src/main/compile/utils.ml +++ b/src/main/compile/utils.ml @@ -14,9 +14,9 @@ let to_core f stx = let%bind core = Of_sugar.compile sugar in ok @@ core -let type_file f stx env : (Ast_typed.program * Typesystem.Solver_types.typer_state, _) result = +let type_file f stx form : (Ast_typed.program * Typesystem.Solver_types.typer_state, _) result = let%bind core = to_core f stx in - let%bind typed,state = Of_core.compile env core in + let%bind typed,state = Of_core.compile form core in ok @@ (typed,state) let to_mini_c f stx env = @@ -32,34 +32,34 @@ let compile_file f stx ep : (Michelson.michelson, _) result = ok @@ contract let type_expression source_file syntax expression env state = - let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) source_file in - let%bind imperative_exp = Of_source.compile_expression v_syntax expression in - let%bind sugar_exp = Of_imperative.compile_expression imperative_exp in - let%bind core_exp = Of_sugar.compile_expression sugar_exp in - let%bind (typed_exp,state) = Of_core.compile_expression ~env ~state core_exp in - ok @@ (typed_exp,state) + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) source_file in + let%bind imperative_exp = Of_source.compile_expression v_syntax expression in + let%bind sugar_exp = Of_imperative.compile_expression imperative_exp in + let%bind core_exp = Of_sugar.compile_expression sugar_exp in + let%bind (typed_exp,state) = Of_core.compile_expression ~env ~state core_exp in + ok @@ (typed_exp,state) let expression_to_mini_c source_file syntax expression env state = - let%bind (typed_exp,_) = type_expression source_file syntax expression env state in - let%bind mini_c_exp = Of_typed.compile_expression typed_exp in - ok @@ mini_c_exp + let%bind (typed_exp,_) = type_expression source_file syntax expression env state in + let%bind mini_c_exp = Of_typed.compile_expression typed_exp in + ok @@ mini_c_exp let compile_expression source_file syntax expression env state = - let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in - let%bind compiled = Of_mini_c.compile_expression mini_c_exp in - ok @@ compiled + let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in + let%bind compiled = Of_mini_c.compile_expression mini_c_exp in + ok @@ compiled let compile_and_aggregate_expression source_file syntax expression env state mini_c_prg = - let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in - let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_exp in - ok @@ compiled + let%bind mini_c_exp = expression_to_mini_c source_file syntax expression env state in + let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c_exp in + ok @@ compiled let compile_storage storage input source_file syntax env state mini_c_prg = - let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in - let%bind imperative = Of_source.compile_contract_input storage input v_syntax in - let%bind sugar = Of_imperative.compile_expression imperative in - let%bind core = Of_sugar.compile_expression sugar in - let%bind typed,_ = Of_core.compile_expression ~env ~state core in - let%bind mini_c = Of_typed.compile_expression typed in - let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in - ok @@ compiled + let%bind v_syntax = Helpers.syntax_to_variant (Syntax_name syntax) (Some source_file) in + let%bind imperative = Of_source.compile_contract_input storage input v_syntax in + let%bind sugar = Of_imperative.compile_expression imperative in + let%bind core = Of_sugar.compile_expression sugar in + let%bind typed,_ = Of_core.compile_expression ~env ~state core in + let%bind mini_c = Of_typed.compile_expression typed in + let%bind compiled = Of_mini_c.aggregate_and_compile_expression mini_c_prg mini_c in + ok @@ compiled diff --git a/src/main/dune b/src/main/dune index 5fa7eb0aa..2a2583375 100644 --- a/src/main/dune +++ b/src/main/dune @@ -6,6 +6,7 @@ compile decompile main_errors + scopes ) (preprocess (pps ppx_let bisect_ppx --conditional) diff --git a/src/main/main.ml b/src/main/main.ml index efdc7e6f2..f94df8896 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -3,3 +3,4 @@ module Compile = Compile module Decompile = Decompile module Display = Display module Formatter = Main_errors.Formatter +module Scopes = Scopes \ No newline at end of file diff --git a/src/main/scopes/PP.ml b/src/main/scopes/PP.ml new file mode 100644 index 000000000..b1ccb1af8 --- /dev/null +++ b/src/main/scopes/PP.ml @@ -0,0 +1,57 @@ +open Types + +let scopes : Format.formatter -> scopes -> unit = fun f s -> + let pp_scope f (s:scope) = + let pp_list f = List.iter (fun (k,_) -> Format.fprintf f "%s " k ) in + let a = Def_map.to_kv_list s.env in + Format.fprintf f "[ %a] %a" pp_list a Location.pp s.range + in + let pp_scopes f = List.iter (Format.fprintf f "@[%a@ @]" pp_scope) in + Format.fprintf f "@[Scopes:@ %a@]" pp_scopes s + +let definitions : Format.formatter -> def_map -> unit = fun f dm -> + let kvl = Def_map.to_kv_list dm in + let (variables,types) = List.partition (fun (_,def) -> match def with Type _ -> false | Variable _ -> true) kvl in + let pp_def f = List.iter (fun (k,v) -> Format.fprintf f "(%s -> %s) %a@ " k (get_def_name v) Location.pp (get_range v)) in + Format.fprintf f "@[Variable definitions:@ %aType definitions:@ %a@]" pp_def variables pp_def types + +let def_to_json : def -> Yojson.t = function + | Variable { name ; range ; body_range ; t ; references=_ } -> + `Assoc [ + ("name", `String name); + ("range", Location.pp_json range); + ("body_range", Location.pp_json body_range); + ("t", match t with None -> `Null | Some t -> Ast_typed.PP_json.Yojson.type_expression t ); + ("references", `Null); + ] + | Type { name ; range ; body_range ; content=_ } -> + `Assoc [ + ("name", `String name); + ("range", Location.pp_json range); + ("body_range", Location.pp_json body_range); + ("content", `String "TODO" ); + ] + +let defs_json d : Yojson.t = + let get_defs d = + let (v,tv) = List.partition (fun (_,def) -> match def with Variable _ -> true | Type _ -> false) (Def_map.to_kv_list d) in + [ + ("variables", `Assoc (List.map (fun (def_id,def) -> (def_id,def_to_json def)) v)); + ("types", `Assoc (List.map (fun (def_id,def) -> (def_id,def_to_json def)) tv)) + ] + in + `Assoc (get_defs d) + +let scopes_json s : Yojson.t = `List ( + List.map + (fun scope -> + let sd = Def_map.to_kv_list scope.env in + let (variables,types) = List.partition (fun (_,def) -> match def with Type _ -> false | Variable _ -> true) sd in + let v = List.map (fun (k,_) -> `String k) variables in + let t = List.map (fun (k,_) -> `String k) types in + (`Assoc [("range", Location.pp_json scope.range) ; ("expression_environment", `List v) ; ("type_environment", `List t)]) + ) + s + ) + +let to_json (d,s) = `Assoc [("definitions", (defs_json d)) ; ("scopes", (scopes_json s))] \ No newline at end of file diff --git a/src/main/scopes/dune b/src/main/scopes/dune new file mode 100644 index 000000000..37b051c1d --- /dev/null +++ b/src/main/scopes/dune @@ -0,0 +1,16 @@ +(library + (name scopes) + (public_name ligo.scopes) + (libraries + main_errors + compile + simple-utils + self_ast_core + typer + ast_typed + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils -open Tezos_utils )) +) diff --git a/src/main/scopes/formatter.ml b/src/main/scopes/formatter.ml new file mode 100644 index 000000000..efa88324c --- /dev/null +++ b/src/main/scopes/formatter.ml @@ -0,0 +1,14 @@ +open Display + +let scope_ppformat ~display_format f ((d,s),_) = + match display_format with + | Human_readable -> + Format.fprintf f "there is to human-readable pretty printer for you, use --format=json" + | Dev -> Format.fprintf f "@[%a@ %a@]" PP.scopes s PP.definitions d + +let scope_jsonformat (defscopes,_) : json = PP.to_json defscopes + +let scope_format : 'a format = { + pp = scope_ppformat; + to_json = scope_jsonformat; +} \ No newline at end of file diff --git a/src/main/scopes/misc.ml b/src/main/scopes/misc.ml new file mode 100644 index 000000000..aab0066d4 --- /dev/null +++ b/src/main/scopes/misc.ml @@ -0,0 +1,55 @@ +open Trace +open Types + +let get_binder_name : 'a Var.t -> string = fun (v: _ Var.t) -> + try Var.to_name v with _ -> "generated" + +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) + +let make_v_def_from_core : string -> string -> string -> Ast_core.expression -> Location.t -> Location.t -> def = + fun source_file syntax name exp range body_range -> + 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 + let%bind (e,_) = Compile.Of_core.compile_expression ~env ~state exp in + ok e.type_expression + in + (* TODO : the source_file is given here but it should only be the declarations seen so far, + otherwise nothing will be typed if an error occurs later in the file *) + make_v_def name t range body_range + +let make_v_def_option_type : string -> string -> string -> Ast_core.type_expression option -> Location.t -> Location.t -> def = + fun source_file syntax name maybe_typed range body_range -> + match maybe_typed with + | Some t -> + let t' = to_option @@ + let%bind typed_prg,_ = Compile.Utils.type_file source_file syntax Env in + let env = Ast_typed.program_environment Environment.default typed_prg in + Compile.Of_core.evaluate_type env t in + make_v_def name t' range body_range + | None -> make_v_def name None range body_range + +let make_v_def_ppx_type : + string -> string -> string -> (Ast_typed.type_expression -> Ast_typed.type_expression) -> + Ast_core.expression -> Location.t -> Location.t -> def = + fun source_file syntax name f exp range body_range -> + 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 + let%bind (e,_) = Compile.Of_core.compile_expression ~env ~state exp in + let v = f e.type_expression in ok v + in + make_v_def name t range body_range \ No newline at end of file diff --git a/src/main/scopes/scopes.ml b/src/main/scopes/scopes.ml new file mode 100644 index 000000000..5fc336e81 --- /dev/null +++ b/src/main/scopes/scopes.ml @@ -0,0 +1,102 @@ +open Trace +open Types +open Misc + +module Formatter = Formatter + +let scopes : string -> string -> ((def_map * scopes), Main_errors.all) result = fun source_file syntax -> + let make_v_def_from_core = make_v_def_from_core source_file syntax in + let make_v_def_option_type = make_v_def_option_type source_file syntax in + let make_v_def_ppx_type = make_v_def_ppx_type source_file syntax in + + 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 } -> ( + 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 e.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 all_defs = merge_defs env all_defs in + find_scopes' (i,all_defs,env,scopes,result.location) result + ) + | E_matching {matchee; cases} -> ( + let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,matchee.location) matchee in + match cases with + | Match_list { match_nil ; match_cons = (hd , tl , match_cons) } -> ( + let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,match_nil.location) match_nil in + let all_defs = merge_defs env all_defs in + (* TODO hd and tl needs location and should be used bellow instead of match_cons .. *) + + 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 (i,env) = add_shadowing_def (i,hd) hd_def env in + let (i,env) = add_shadowing_def (i,tl) tl_def env in + + let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,match_cons.location) match_cons in + let all_defs = merge_defs env all_defs in + (i,all_defs,env,scopes) + ) + | Match_option { match_none ; match_some = (some , match_some) } -> ( + let (i,all_defs,_,scopes) = find_scopes' (i,all_defs,env,scopes,match_none.location) match_none in + 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 (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 + let all_defs = merge_defs env all_defs in + (i,all_defs,env,scopes) + ) + | Match_variant lst -> ( + let aux = fun (i,all_defs,scopes) ((c,proj),(match_variant:Ast_core.expression)) -> + let proj_f = fun (t:Ast_typed.type_expression) -> match Ast_typed.get_t_sum t with + | Some t -> (Ast_typed.CMap.find (Ast_typed.Environment.convert_constructor' c) t).ctor_type + | 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 (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 + (i,all_defs,scopes) + in + let (i,all_defs,scopes) = List.fold_left aux (i,all_defs,scopes) lst in + (i,all_defs,env,scopes) + ) + ) + | E_ascription { anno_expr ; _ } -> find_scopes' (i,all_defs,env,scopes,anno_expr.location) anno_expr + | _ -> + let scopes = add_scope (lastloc, env) scopes in + (i,all_defs,env,scopes) + in + let find_scopes (i,top_lvl_defs,scopes,loc) e = + let (i,defs,_,scopes) = find_scopes' (i,top_lvl_defs,top_lvl_defs,scopes,loc) e in + (i,defs,scopes) in + + let aux = fun (i,top_def_map,inner_def_map,scopes) (x : Ast_core.declaration Location.wrap) -> + 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 (i,top_def_map) = add_shadowing_def (i,v) def top_def_map in + ( i, top_def_map, inner_def_map, scopes ) + + | Declaration_type (tv, te) -> + let def = make_t_def (get_binder_name tv) x te in + let (i,top_def_map) = add_shadowing_def (i,tv) def top_def_map in + ( i, top_def_map, inner_def_map, scopes ) + + in + + let%bind (core_prg : Ast_core.program) = Compile.Utils.to_core source_file syntax in + let (_,top_d,inner_d,s) = List.fold_left aux (0, Def_map.empty ,Def_map.empty, []) core_prg in + let d = Def_map.union (fun _ outter _ -> Some outter) top_d inner_d in + ok (d,s) \ No newline at end of file diff --git a/src/main/scopes/types.ml b/src/main/scopes/types.ml new file mode 100644 index 000000000..2aa6de886 --- /dev/null +++ b/src/main/scopes/types.ml @@ -0,0 +1,45 @@ +module Definitions = struct + module Def_map = Map.Make( struct type t = string let compare = String.compare end) + + type vdef = { + name : string ; + range : Location.t ; + body_range : Location.t ; + t : Ast_typed.type_expression option ; + references : (Location.t list) option + } + type tdef = { + name : string ; + range : Location.t ; + body_range : Location.t ; + content : Ast_core.type_expression + } + type def = Variable of vdef | Type of tdef + type def_map = def Def_map.t + + let merge_defs a b = Def_map.union (fun _ a _ -> Some a) a b + + let get_def_name = function + | Variable d -> d.name + | Type d -> d.name + + let get_range = function + | Type t -> t.range + | Variable v -> v.range + + let make_v_def : string -> Ast_typed.type_expression option -> Location.t -> Location.t -> def = + fun name t range body_range -> + Variable { name ; range ; body_range ; t ; references = None } + + let make_t_def : string -> Ast_core.declaration Location.wrap -> Ast_core.type_expression -> def = + fun name decl te -> + Type { name ; range = decl.location ; body_range = te.location ; content = te } + +end + +include Definitions + +type scope = { range : Location.t ; env : def_map } +type scopes = scope list + +let add_scope (range,env) scopes = { range ; env } :: scopes \ No newline at end of file diff --git a/src/passes/09-typing/typer.ml b/src/passes/09-typing/typer.ml index b33d2551c..618b58006 100644 --- a/src/passes/09-typing/typer.ml +++ b/src/passes/09-typing/typer.ml @@ -15,5 +15,7 @@ type environment = Environment.t let type_program = Typer_old.type_program let type_expression_subst = if use_new_typer then Typer_new.type_expression_subst else Typer_old.type_expression (* the old typer does not have unification variables that would need substitution, so no need to "subst" anything. *) let untype_expression = if use_new_typer then Typer_new.untype_expression else Typer_old.untype_expression +let evaluate_type = if use_new_typer then Typer_new.evaluate_type else Typer_old.evaluate_type + let assert_type_expression_eq = Typer_common.Helpers.assert_type_expression_eq diff --git a/src/passes/09-typing/typer.mli b/src/passes/09-typing/typer.mli index 9b37e44de..9bd7c5be7 100644 --- a/src/passes/09-typing/typer.mli +++ b/src/passes/09-typing/typer.mli @@ -15,5 +15,6 @@ type environment = Environment.t val type_program : I.program -> (O.program * O'.typer_state, Errors.typer_error) result val type_expression_subst : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state , Errors.typer_error) result val untype_expression : O.expression -> (I.expression , Errors.typer_error) result +val evaluate_type : environment -> O.ast_core_type_expression -> (O.type_expression, Errors.typer_error) result val assert_type_expression_eq : O.type_expression * O.type_expression -> (unit, Errors.typer_error) result \ No newline at end of file diff --git a/src/stages/5-ast_typed/PP_json.ml b/src/stages/5-ast_typed/PP_json.ml index 0bcddfc32..57f56a83c 100644 --- a/src/stages/5-ast_typed/PP_json.ml +++ b/src/stages/5-ast_typed/PP_json.ml @@ -80,7 +80,7 @@ module M = struct fold to_json NoState v let print : ((no_state, json) fold_config -> no_state -> 'a -> json) -> formatter -> 'a -> unit = fun fold ppf v -> - fprintf ppf "%a" Yojson.Basic.pp (to_json fold v) + fprintf ppf "%a" Yojson.pp (to_json fold v) end module Yojson = Fold.Folds(struct diff --git a/src/stages/5-ast_typed/environment.mli b/src/stages/5-ast_typed/environment.mli index d73279d85..e39aebcbb 100644 --- a/src/stages/5-ast_typed/environment.mli +++ b/src/stages/5-ast_typed/environment.mli @@ -10,6 +10,7 @@ val add_type : type_variable -> type_expression -> t -> t val get_opt : expression_variable -> t -> element option val get_type_opt : type_variable -> t -> type_expression option val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option +val convert_constructor' : S.constructor' -> constructor' val add_ez_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment module PP : sig diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 46d976a9f..6576dcd52 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -320,6 +320,14 @@ let to_option = function | Ok (o, annotations) -> ignore annotations; Some o | Error _ -> None +(** + Convert a result to a json, if res in an error, the produces JSON will be + empty, otherwise the provided to_json function will be used +*) +let to_json to_json = function + | Ok (v,_) -> to_json v + | Error _ -> `Null + (** Convert an option to a result, with a given error if the parameter is None. *) @@ -331,6 +339,7 @@ let trace_assert_fail_option error = function None -> ok () | Some _s -> fail error + (** Utilities to interact with other data-structure. [bind_t] takes an ['a result t] and makes a ['a t result] out of it. It "lifts" the error out of the type. The most common context is when mapping a