get-scope command. New module Ligo.scopes

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

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

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

src/main/dune

@@ -6,6 +6,7 @@
     compile
     decompile
     main_errors
+    scopes
   )
   (preprocess
     (pps ppx_let bisect_ppx --conditional)

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

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 "@[<v>%a@ @]" pp_scope) in
+  Format.fprintf f "@[<v>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 "@[<v>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))]

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

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 "@[<v>%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;
+}

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

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)

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

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

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

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

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

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