diff --git a/dune-network b/dune-network index 7ddbe8c5..9ee1a98d 160000 --- a/dune-network +++ b/dune-network @@ -1 +1 @@ -Subproject commit 7ddbe8c5e078424bdbad815c0bfef05602548f5d +Subproject commit 9ee1a98dad8b59e25adb462a7d2205ecbb63cdda diff --git a/libs/dune-network-lib/build.ocp2 b/libs/dune-network-lib/build.ocp2 index 4f85202c..68f64547 100644 --- a/libs/dune-network-lib/build.ocp2 +++ b/libs/dune-network-lib/build.ocp2 @@ -379,92 +379,104 @@ OCaml.library("dune-network-lib-env", "dune-network-lib-love-parsing", ["Dune_love_parsing"]; ])); +proto_files = [ + (* Love *) + from_dune_proto("contract_hash.ml"); + "storage_description.ml"; + from_dune_proto("contract_repr.ml"); + from_dune_proto("qty_repr.ml"); + from_dune_proto("tez_repr.ml"); + from_dune_proto("script_int_repr.ml"); + from_dune_proto("period_repr.ml"); + from_dune_proto("time_repr.ml"); + from_dune_proto("script_timestamp_repr.ml"); + from_dune_proto("script_expr_hash.ml"); + from_dune_proto("love_pervasives.ml"); + from_dune_proto("love_type.ml"); + from_dune_proto("love_type_list.ml"); + from_dune_proto("love_primitive.ml"); + from_dune_proto("love_ast.ml"); + from_dune_proto("love_runtime_ast.ml"); + from_dune_proto("love_value.ml"); + from_dune_proto("love_printer.ml"); + from_dune_proto("love_encoding_sig.ml"); + from_dune_proto("love_json_encoding.ml"); + from_dune_proto("love_tenv.ml"); + + from_dune_proto("gas_limit_repr.ml"); + from_dune_proto("michelson_v1_primitives.ml"); + from_dune_proto("script_repr.ml"); + (* from_dune_proto("gas_limit_repr.ml"); + * from_dune_proto("michelson_v1_primitives.ml"); + * from_dune_proto("script_repr.ml"); + * from_dune_proto("lang1_repr.ml"); + * from_dune_proto("lang1_script_repr.ml"); + * from_dune_proto("love_repr.ml"); + * from_dune_proto("love_script_repr.ml"); + * from_dune_proto("dune_lang_repr.ml"); + * from_dune_proto("dune_script_sig.ml"); + * from_dune_proto("dune_script_registration.ml"); + * from_dune_proto("dune_script_repr.ml"); + * from_dune_proto("dune_misc.ml"); + * from_dune_proto("love_size.ml"); + * from_dune_proto("love_binary_buffer.ml"); + * from_dune_proto("love_binary_encoding.ml"); + * from_dune_proto("love_encoding.ml"); + * from_dune_proto("nonce_hash.ml"); + * from_dune_proto("blinded_public_key_hash.ml"); + * from_dune_proto("dune_parameters_repr.ml"); + * from_dune_proto("commitment_repr.ml"); + * from_dune_proto("constants_repr.ml"); + * from_dune_proto("constants_repr.ml"); + * from_dune_proto("alpha_context.ml"); *) + + (* from_dune_proto("love_script_repr.ml"); *) + + (* from_dune_proto("love_size.ml"); *) + from_dune_proto("love_binary_buffer.ml"); + from_dune_proto("love_binary_processor.ml"); + from_dune_proto("love_binary_encoding.ml"); + from_dune_proto("love_encoding.ml"); + from_dune_proto("raw_level_repr.ml"); + from_dune_proto("cycle_repr.ml"); + from_dune_proto("voting_period_repr.ml"); + + "alpha_context.ml"; + from_dune_proto("love_size.ml"); + from_dune_proto("love_gas.ml"); + (* from_dune_proto("love_michelson.ml"); *) + from_dune_proto("love_context.ml"); + from_dune_proto("love_free_vars.ml"); + from_dune_proto("love_env.ml"); + "love_translator.ml"; + "love_michelson.ml"; + (* from_dune_proto("love_translator.ml"); *) + from_dune_proto("love_typechecker.ml"); + from_dune_proto("love_prim_interp.ml"); + from_dune_proto("love_prim_list.ml"); + + (* "alpha_context.ml"; *) + (* from_dune_proto("love_context.ml"); + * from_dune_proto("love_prim_interp.ml"); + * from_dune_proto("love_prim_list.ml"); *) +]; + +solidity_files = [ + from_dune_proto("solidity_common.ml"); + from_dune_proto("solidity_ast.ml"); + from_dune_proto("solidity_runtime_ast.ml"); + from_dune_proto("solidity_visitor.ml"); + from_dune_proto("solidity_json_encoding.ml"); + from_dune_proto("solidity_printer.ml"); +]; + + OCaml.library("dune-network-lib-protocol", with_libs(ocaml + { bytelink = [ "-custom" ]; files = OCaml.pack("Tezos_protocol", - OCaml.pack("Protocol", [ - (* Love *) - from_dune_proto("contract_hash.ml"); - "storage_description.ml"; - from_dune_proto("contract_repr.ml"); - from_dune_proto("qty_repr.ml"); - from_dune_proto("tez_repr.ml"); - from_dune_proto("script_int_repr.ml"); - from_dune_proto("period_repr.ml"); - from_dune_proto("time_repr.ml"); - from_dune_proto("script_timestamp_repr.ml"); - from_dune_proto("script_expr_hash.ml"); - from_dune_proto("love_pervasives.ml"); - from_dune_proto("love_type.ml"); - from_dune_proto("love_type_list.ml"); - from_dune_proto("love_primitive.ml"); - from_dune_proto("love_ast.ml"); - from_dune_proto("love_runtime_ast.ml"); - from_dune_proto("love_value.ml"); - from_dune_proto("love_printer.ml"); - from_dune_proto("love_encoding_sig.ml"); - from_dune_proto("love_json_encoding.ml"); - from_dune_proto("love_tenv.ml"); - - from_dune_proto("gas_limit_repr.ml"); - from_dune_proto("michelson_v1_primitives.ml"); - from_dune_proto("script_repr.ml"); - (* from_dune_proto("gas_limit_repr.ml"); - * from_dune_proto("michelson_v1_primitives.ml"); - * from_dune_proto("script_repr.ml"); - * from_dune_proto("lang1_repr.ml"); - * from_dune_proto("lang1_script_repr.ml"); - * from_dune_proto("love_repr.ml"); - * from_dune_proto("love_script_repr.ml"); - * from_dune_proto("dune_lang_repr.ml"); - * from_dune_proto("dune_script_sig.ml"); - * from_dune_proto("dune_script_registration.ml"); - * from_dune_proto("dune_script_repr.ml"); - * from_dune_proto("dune_misc.ml"); - * from_dune_proto("love_size.ml"); - * from_dune_proto("love_binary_buffer.ml"); - * from_dune_proto("love_binary_encoding.ml"); - * from_dune_proto("love_encoding.ml"); - * from_dune_proto("nonce_hash.ml"); - * from_dune_proto("blinded_public_key_hash.ml"); - * from_dune_proto("dune_parameters_repr.ml"); - * from_dune_proto("commitment_repr.ml"); - * from_dune_proto("constants_repr.ml"); - * from_dune_proto("constants_repr.ml"); - * from_dune_proto("alpha_context.ml"); *) - - (* from_dune_proto("love_script_repr.ml"); *) - - (* from_dune_proto("love_size.ml"); *) - from_dune_proto("love_binary_buffer.ml"); - from_dune_proto("love_binary_processor.ml"); - from_dune_proto("love_binary_encoding.ml"); - from_dune_proto("love_encoding.ml"); - from_dune_proto("raw_level_repr.ml"); - from_dune_proto("cycle_repr.ml"); - from_dune_proto("voting_period_repr.ml"); - - "alpha_context.ml"; - from_dune_proto("love_size.ml"); - from_dune_proto("love_gas.ml"); - (* from_dune_proto("love_michelson.ml"); *) - from_dune_proto("love_context.ml"); - from_dune_proto("love_free_vars.ml"); - from_dune_proto("love_env.ml"); - "love_translator.ml"; - "love_michelson.ml"; - (* from_dune_proto("love_translator.ml"); *) - from_dune_proto("love_typechecker.ml"); - from_dune_proto("love_prim_interp.ml"); - from_dune_proto("love_prim_list.ml"); - - (* "alpha_context.ml"; *) - (* from_dune_proto("love_context.ml"); - * from_dune_proto("love_prim_interp.ml"); - * from_dune_proto("love_prim_list.ml"); *) - ])); + OCaml.pack("Protocol", proto_files)); requires = []; }, [ "dune-network-lib-env", [ "Environment", { filename = "environment" }; @@ -473,7 +485,6 @@ OCaml.library("dune-network-lib-protocol", "dune-network-lib-config", ["Dune_config"]; ])); - OCaml.library("dune-network-lib-love-parsing", with_libs(ocaml + { files = OCaml.pack("Dune_love_parsing", [ @@ -491,6 +502,69 @@ OCaml.library("dune-network-lib-love-parsing", "dune-network-lib-base_s", ["Tezos_base_S"]; ])); +OCaml.library("dune-network-lib-protocol-with-solidity", + with_libs(ocaml + { + bytelink = [ "-custom" ]; + files = + OCaml.pack("Tezos_protocol_sol", + OCaml.pack("Protocol", proto_files + solidity_files)); + requires = []; + + }, [ "dune-network-lib-env", [ "Environment", { filename = "environment" }; + "Error_monad", { dep = false } ]; + "dune-network-lib-rpc", ["Tezos_rpc"]; + "dune-network-lib-config", ["Dune_config"]; + ])); + +(* +OCaml.library("dune-network-lib-solidity-parsing", + with_libs(ocaml + { + files = OCaml.pack("Dune_solidity_parsing", [ + from_dune_proto_client("solidity_parser.mly"), { + ocamlyacc = [ "menhir"; "--fixed-exception" ] }; + from_dune_proto_client("solidity_lexer.mll"); + ]); + }, [ + "dune-network-lib-protocol-with-solidity", ["Tezos_protocol_sol"]; + "dune-network-lib-base", ["Tezos_base"; + "TzPervasives", { dep = false } ]; + "dune-network-lib-base_s", ["Tezos_base_S"]; + ])); *) + +open_tezos = ["-open"; "Tezos_protocol_sol" ]; + +open_std = [ + "-open"; "Tezos_stdlib" ; + "-open"; "Tezos_base" ; + "-open"; "Tezos_protocol_sol" ; + "-open"; "Tezos_crypto" ; +]; + +with_tezos = { + asmcomp = ocaml.asmcomp + open_tezos; + bytecomp = ocaml.bytecomp + open_tezos; +}; + +with_base = { + asmcomp = ocaml.asmcomp + open_std; + bytecomp = ocaml.bytecomp + open_std; +}; + +OCaml.library("dune-network-lib-solidity-parsing", ocaml + { + files = [ + from_dune_proto_client("solidity_parser.mly"), { + ocamlyacc = [ "menhir"; "--fixed-exception" ] } + with_tezos ; + from_dune_proto_client("solidity_lexer.mll"), with_base; + ]; + requires = [ + "dune-network-lib-protocol-with-solidity"; + "dune-network-lib-stdlib"; + "dune-network-lib-base"; + "dune-network-lib-crypto"; + ] + }); + + OCaml.library("dune-network-lib-michelson-macros", with_libs(ocaml + { files = [ diff --git a/tools/client/build.ocp2 b/tools/client/build.ocp2 index 087b235d..ab2f23e7 100644 --- a/tools/client/build.ocp2 +++ b/tools/client/build.ocp2 @@ -1,4 +1,3 @@ - OCaml.library("ocplib-liquidity-client-functor", ocaml + { files = [ @@ -8,6 +7,8 @@ OCaml.library("ocplib-liquidity-client-functor", "liquidClientSigs.ml"; "liquidClientRequest.ml"; "liquidClientTypes.ml"; + "liquidTraceRepr.mli"; + "liquidTraceRepr.ml"; "liquidClientErrors.ml"; "liquidClientRPCs.ml"; "liquidClient.ml"; @@ -52,6 +53,16 @@ OCaml.library("ocplib-liquidity-to-love-client", ]; }); +OCaml.library("ocplib-solidity-client", + ocaml + { + files = [ "solidityLang.ml" ]; + requires = [ + "dune-network-lib-protocol-with-solidity"; + "dune-network-lib-solidity-parsing"; + "ocplib-liquidity-client-functor"; + ]; + }); + OCaml.program("liquidity-client", ocaml + { bytelink = ["-cclib"; "-lsodium_stubs -lsodium"]; @@ -66,6 +77,7 @@ OCaml.program("liquidity-client", "ocplib-liquidity-base"; "ocplib-liquidity-init"; "ezcmd"; + "ocplib-solidity-client"; ]; }); diff --git a/tools/client/liquidClient.ml b/tools/client/liquidClient.ml index ad9a47d9..a1895efe 100644 --- a/tools/client/liquidClient.ml +++ b/tools/client/liquidClient.ml @@ -9,15 +9,8 @@ open Lwt.Infix open Dune_Network_Lib.Stdlib open Dune_Network_Lib.Crypto (* for crypto *) -module Liquidity = LiquidityLang - -type liquidity_datatype = Liquidity.datatype Lazy_superposed.t -type liquidity_const = Liquidity.const Lazy_superposed.t -type liquidity_contract = Liquidity.contract Lazy_superposed.t - - module Make (L : LANG) = struct - + module L = L module RPC = LiquidClientRPCs.Make(L) module E = RPC.E @@ -28,11 +21,17 @@ module Make (L : LANG) = struct open T open RPC + type source_datatype = Source.datatype Lazy_superposed.t + type source_const = Source.const Lazy_superposed.t + type source_contract = Source.contract Lazy_superposed.t + type target_datatype = Target.datatype Lazy_superposed.t type target_const = Target.const Lazy_superposed.t type target_contract = Target.contract Lazy_superposed.t - type liq_big_map_diff = (bm_id, Liquidity.const) Big_map_diff.t + type liq_big_map_diff = (bm_id, Source.const) Big_map_diff.t + + module SourceOperation = OperationMake (Source) let get_private_key ?private_key () = match private_key, !LiquidOptions.private_key with @@ -68,7 +67,7 @@ module Make (L : LANG) = struct | Some counter -> Lwt.return counter let big_map_info storage storage_ty id = - Liquidity.list_big_maps storage storage_ty + Source.list_big_maps storage storage_ty |> List.find_opt (fun ((Bm_id i | Bm_name (i, _)), _, _) -> i = id) let id_of_info id info = match info with @@ -153,11 +152,14 @@ module Make (L : LANG) = struct | None -> get_head () let run_pre ?(debug=false) ?(amount = !LiquidOptions.amount) - source_contract target_contract loc_table ?source entry_name input storage = + source_contract + target_contract + loc_table + ?source entry_name input storage = let rpc = if debug then RPC.trace else RPC.run in - let storage_ty = Liquidity.storage source_contract in + let storage_ty = Source.storage source_contract in let input_ty = - match List.assoc_opt entry_name (Liquidity.entries source_contract) with + match List.assoc_opt entry_name (Source.entries source_contract) with | Some ty -> ty | None -> failwith ("Contract has no entry point " ^ entry_name) in let input = compile_const ~ty:input_ty input in @@ -204,7 +206,7 @@ module Make (L : LANG) = struct let get_storage contract address = let _ = compile_contract contract in RPC.get_storage address >|= fun storage -> - try decompile_const storage ~ty:(Liquidity.storage contract) + try decompile_const storage ~ty:(Source.storage contract) with _ -> Format.eprintf "Could not convert constant to contract storage type.@."; decompile_const storage @@ -248,13 +250,13 @@ module Make (L : LANG) = struct let build_big_map_subst const const_ty big_map_diff = let open Big_map_diff in - Liquidity.list_big_maps const const_ty |> + Source.list_big_maps const const_ty |> List.map (fun ((Bm_id i | Bm_name (i, _)), _, _) -> i, big_map_elements i big_map_diff ) let replace_init_big_maps big_map_diff storage storage_ty = - Liquidity.apply_big_map_subst + Source.apply_big_map_subst (build_big_map_subst storage storage_ty big_map_diff) storage @@ -264,7 +266,7 @@ module Make (L : LANG) = struct try Some (get_source ?source ()) with _ -> None in match comp_init, init_params with - | Liquidity.No_init, [c] + | Source.No_init, [c] | Init_constant c, [] -> Lwt.return c | No_init, [] -> @@ -281,9 +283,9 @@ module Make (L : LANG) = struct "init_storage: init storage needs %d arguments, but was given %d" l_req l_giv ; let param = match init_params with - | [] -> Liquidity.unit + | [] -> Source.unit | [x] -> x - | _ -> Liquidity.tuple init_params + | _ -> Source.tuple init_params in Lwt.return param @@ -295,13 +297,13 @@ module Make (L : LANG) = struct l_req l_giv; let eval_input_storage = try - Liquidity.default_empty_const (Liquidity.storage contract) + Source.default_empty_const (Source.storage contract) with Not_found -> failwith "could not construct dummy storage for eval" in let eval_input_parameter = match init_params with - | [] -> Liquidity.unit + | [] -> Source.unit | [x] -> x - | _ -> Liquidity.tuple init_params + | _ -> Source.tuple init_params in let ct, _, loc_table = compile_contract c in @@ -310,7 +312,7 @@ module Make (L : LANG) = struct >>= fun (_, eval_init_storage, big_map_diff, _) -> (* Add elements of big map *) let eval_init_storage = - replace_init_big_maps big_map_diff eval_init_storage (Liquidity.storage contract) in + replace_init_big_maps big_map_diff eval_init_storage (Source.storage contract) in Lwt.return eval_init_storage @@ -320,11 +322,11 @@ module Make (L : LANG) = struct let ty = match comp_init with | Init_components args_tys -> (match args_tys with - | [] -> Tunit + | [] -> Source.tunit | [_, ty] -> ty - | _ -> Ttuple (List.map snd args_tys) + | _ -> Source.ttuple (List.map snd args_tys) ) - | _ -> Liquidity.storage contract in + | _ -> Source.storage contract in compile_const ~ty init @@ -571,7 +573,7 @@ module Make (L : LANG) = struct ~loc_table address ?contract entry_name input = let input_ty = match contract with | None -> None - | Some c -> match List.assoc_opt entry_name (Liquidity.entries c) with + | Some c -> match List.assoc_opt entry_name (Source.entries c) with | None -> failwith ("Contract has no entry point " ^ entry_name) | ty -> ty in let input_t = compile_const ?ty:input_ty input in @@ -687,11 +689,11 @@ module Make (L : LANG) = struct let open Big_map_diff in function | Big_map_add { id; key_hash; key; value } -> - let key = Liquidity.const#ast key in - let value = Liquidity.const#ast value in + let key = Source.const#ast key in + let value = Source.const#ast value in Big_map_add { id; key_hash; key; value } | Big_map_remove { id; key_hash; key } -> - let key = Liquidity.const#ast key in + let key = Source.const#ast key in Big_map_remove { id; key_hash; key } | Big_map_delete { id } -> Big_map_delete { id } @@ -719,59 +721,59 @@ module Make (L : LANG) = struct type 'a t val init_storage : ?source:string -> - liquidity_contract -> - liquidity_const list -> target_const t + source_contract -> + source_const list -> target_const t val run : ?amount : LiquidNumber.tez -> - liquidity_contract -> + source_contract -> string -> - liquidity_const -> - liquidity_const -> - (LiquidityOperation.internal list * liquidity_const * - (bm_id, liquidity_const) Big_map_diff.item + source_const -> + source_const -> + (SourceOperation.internal list * source_const * + (bm_id, source_const) Big_map_diff.item list) t val run_debug : ?amount : LiquidNumber.tez -> - liquidity_contract -> + source_contract -> string -> - liquidity_const -> - liquidity_const -> - (LiquidityOperation.internal list * liquidity_const * - (bm_id, liquidity_const) Big_map_diff.item + source_const -> + source_const -> + (SourceOperation.internal list * source_const * + (bm_id, source_const) Big_map_diff.item list * - (Liquidity.location, liquidity_const) Trace.trace_item list) + (Source.location, source_const) Trace.trace_item list) t val deploy : ?balance : LiquidNumber.tez -> - liquidity_contract -> - liquidity_const list -> (string * string) t + source_contract -> + source_const list -> (string * string) t val get_storage : - liquidity_contract -> string -> liquidity_const t + source_contract -> string -> source_const t val get_big_map_value : - bm_id * liquidity_datatype * liquidity_datatype -> - liquidity_const -> liquidity_const option t + bm_id * source_datatype * source_datatype -> + source_const -> source_const option t val call : - ?contract:liquidity_contract -> + ?contract:source_contract -> ?amount : LiquidNumber.tez -> - address:string -> entry:string -> liquidity_const -> string t + address:string -> entry:string -> source_const -> string t val activate : secret:string -> string t val inject : operation:bytes -> signature:string -> string t val pack : - const:liquidity_const -> ty:liquidity_datatype -> bytes t + const:source_const -> ty:source_datatype -> bytes t val forge_deploy : ?head:Header.t -> ?source:string -> ?public_key:string -> ?balance : LiquidNumber.tez -> - liquidity_contract -> liquidity_const list -> bytes t + source_contract -> source_const list -> bytes t val forge_call : ?head:Header.t -> ?source:string -> ?public_key:string -> - ?contract:liquidity_contract -> + ?contract:source_contract -> ?amount : LiquidNumber.tez -> - address:string -> entry:string -> liquidity_const -> bytes t + address:string -> entry:string -> source_const -> bytes t end (* Withoud optional argument head *) @@ -784,13 +786,17 @@ module Make (L : LANG) = struct >|= fun storage -> Target.const#ast storage - let run ?amount contract entry_name input storage = + let run ?amount contract entry_name input storage : + (SourceOperation.internal list * source_const * + (LiquidClientUtils.bm_id, source_const) + LiquidClientTypes.Big_map_diff.item list) + Lwt.t = let contract = contract#ast in let input = input#ast in let storage = storage#ast in run ?amount contract entry_name input storage >|= fun (ops, storage, bm) -> - (ops, Liquidity.const#ast storage, print_big_map_diff bm) + (ops, Source.const#ast storage, print_big_map_diff bm) let run_debug ?amount contract entry_name input storage = let contract = contract#ast in @@ -798,7 +804,7 @@ module Make (L : LANG) = struct let storage = storage#ast in run_debug ?amount contract entry_name input storage >|= fun (ops, storage, bm, trace) -> - (ops, Liquidity.const#ast storage, print_big_map_diff bm, print_trace trace) + (ops, Source.const#ast storage, print_big_map_diff bm, print_trace trace) let deploy ?balance contract args = let contract = contract#ast in @@ -809,7 +815,7 @@ module Make (L : LANG) = struct let contract = contract#ast in get_storage contract address >|= fun storage -> - Liquidity.const#ast storage + Source.const#ast storage let get_big_map_value (id, tk, tv) key = let id = id, tk#ast, tv#ast in @@ -817,7 +823,7 @@ module Make (L : LANG) = struct get_big_map_value id key >|= function | None -> None - | Some v -> Some (Liquidity.const#ast v) + | Some v -> Some (Source.const#ast v) let call ?contract ?amount ~address ~entry parameter = let contract = match contract with diff --git a/tools/client/liquidClientErrors.ml b/tools/client/liquidClientErrors.ml index aa5f51b8..2f9112bb 100644 --- a/tools/client/liquidClientErrors.ml +++ b/tools/client/liquidClientErrors.ml @@ -5,191 +5,305 @@ open LiquidClientTypes open LiquidTypes open Lwt.Infix -module Liquidity = LiquidityLang -type error = location * string -type trace = (location, syntax_const Lazy_superposed.t) Trace.t +exception UnknownException -exception RuntimeError of error * trace option * Ezjsonm.value -exception LocalizedError of error * Ezjsonm.value -exception RuntimeFailure of error * syntax_const Lazy_superposed.t option * - trace option * Ezjsonm.value +type trace = LiquidTraceRepr.t + +module type Err = sig + type const + type error + + exception RuntimeError of error * trace option * Ezjsonm.value + exception LocalizedError of error * Ezjsonm.value + exception RuntimeFailure of error * const Lazy_superposed.t option * + trace option * Ezjsonm.value + + val error_name : exn -> string + + val report_err : Format.formatter -> exn -> unit + + val error_json : exn -> Ezjsonm.value + + val trace : exn -> trace option + + val error_loc : exn -> LiquidTypes.location +end + +(* Updated at each call of the Make functor. *) +let error_modules : (module Err) list ref = ref [] + +let get_module exn = + let rec loop = function + | [] -> raise UnknownException + | (module M : Err) :: tl -> + match exn with + | M.RuntimeError _ + | M.LocalizedError _ + | M.RuntimeFailure _ -> (module M : Err) + | _ -> loop tl + in loop !error_modules + +let error_name exn = + let (module M : Err) = get_module exn in + M.error_name exn + +let error_json exn = + let (module M : Err) = get_module exn in + M.error_json exn + +let report_err fmt exn = + let (module M : Err) = get_module exn in + M.report_err fmt exn + +let trace exn = + let (module M : Err) = get_module exn in + M.trace exn + +let error_loc exn = + let (module M : Err) = get_module exn in + M.error_loc exn module Make (L : LANG) = struct - open L - module T = LiquidClientTypes.Make(L) - - let name_of_var_annot = function - | None -> None - | Some annot -> - try Scanf.sscanf annot "@%s" (function - | "" -> None - | s -> Some s - ) - with Scanf.Scan_failure _ | End_of_file -> None - - let convert_stack stack_expr = - List.(rev @@ rev_map (fun (e, annot) -> - let name = name_of_var_annot annot in - let c = decompile_const e |> Liquidity.const#ast in - c, name - ) stack_expr) - - let convert_trace ~loc_table t = - List.(rev @@ rev_map (fun Trace.{ loc; gas; stack } -> - let loc = match loc with - | None -> None - | Some loc -> match List.assoc_opt loc loc_table with - | Some (loc, _) -> Some loc + module Result = struct + module L = L + open L + type location = Source.location + type const = Source.const + type error = location * string + + module T = LiquidClientTypes.Make(L) + + module TraceRepr = LiquidTraceRepr.MakeTrace(L) + + exception RuntimeError of error * LiquidTraceRepr.t option * Ezjsonm.value + exception LocalizedError of error * Ezjsonm.value + exception RuntimeFailure of error * const Lazy_superposed.t option * + LiquidTraceRepr.t option * Ezjsonm.value + + let error = function + RuntimeError (err, _, _) + | LocalizedError (err, _) + | RuntimeFailure (err, _, _, _) -> err + + | _ -> raise UnknownException + + let error_loc exn = L.Source.normalize_loc (fst (error exn)) + + let error_name exn = snd (error exn) + + let error_json =function + RuntimeError (_, _, json) + | LocalizedError (_, json) + | RuntimeFailure (_, _, _, json) -> json + + | _ -> raise UnknownException + + let trace = function + | LocalizedError _ -> None + | RuntimeError (_, t, _) + | RuntimeFailure (_, _, t, _) -> t + + | _ -> raise UnknownException + + let pp_err ~kind fmt (err_loc, err_msg) = + Format.fprintf fmt "%a: %s: @[%s@]\n%!" Source.print_loc err_loc kind err_msg + + let report_err fmt exn = match exn with + | RuntimeError (err, _, _) -> + pp_err ~kind:"Runtime error" fmt err + | LocalizedError (err, _) -> + pp_err ~kind:"Error" fmt err + | RuntimeFailure (err, v, _, _) -> begin + pp_err ~kind:"Failed at runtime" fmt err; + match v with + | None -> () + | Some v -> + Format.eprintf "Failed with %s@." v#string + end + + | _ -> raise UnknownException (* Should not happen *) + + let name_of_var_annot = function + | None -> None + | Some annot -> + try Scanf.sscanf annot "@%s" (function + | "" -> None + | s -> Some s + ) + with Scanf.Scan_failure _ | End_of_file -> None + + let convert_stack stack_expr = + List.(rev @@ rev_map (fun (e, annot) -> + let name = name_of_var_annot annot in + let c = decompile_const e |> Source.const#ast in + c, name + ) stack_expr) + + let convert_trace ~loc_table t = + List.(rev @@ rev_map (fun Trace.{ loc; gas; stack } -> + let loc = match loc with | None -> None + | Some loc -> match List.assoc_opt loc loc_table with + | Some (loc, _) -> Some loc + | None -> None + in + let stack = convert_stack stack in + Trace.{ loc; gas; stack } + ) t) + + let trace_of_json ~loc_table ?(error=false) trace_r = + let trace_expr = + Json_encoding.destruct + (Trace.encoding Target.loc_encoding Target.const_encoding) trace_r in + let trace_expr = match List.rev trace_expr with + | (Trace.{loc = Some l ; gas; _} :: _) as rtrace_expr when error -> + let extra = Trace.{loc = Some (Target.next_loc l); gas; stack = []} in + List.rev (extra :: rtrace_expr) + | _ -> trace_expr in + convert_trace ~loc_table trace_expr + + + let fail_of_err loc ~loc_table err = + let json = Ezjsonm.find err ["with"] in + let err_loc, _ (* failwith_ty *) = List.assoc loc loc_table in + let failed_with_expr = Json_encoding.destruct Target.const_encoding json in + let failed_with = decompile_const failed_with_expr |> Source.const#ast in + err_loc, Some failed_with + + let error_trace_of_err loc ~loc_table err = + let err_loc, _ = List.assoc loc loc_table in + try + let json = Ezjsonm.find err ["trace"] in + let trace = trace_of_json ~loc_table ~error:true json in + err_loc, Some trace + with Not_found -> err_loc, None + + let raise_error_from_l ?loc_table ~original_json err_msg l = + let default_error () = + let last_descr = match List.rev l with + | (_, _, _, _, Some descr, _) :: _ -> "\n " ^ descr + | _ -> "" in - let stack = convert_stack stack in - Trace.{ loc; gas; stack } - ) t) - - let trace_of_json ~loc_table ?(error=false) trace_r = - let trace_expr = - Json_encoding.destruct - (Trace.encoding Target.loc_encoding Target.const_encoding) trace_r in - let trace_expr = match List.rev trace_expr with - | (Trace.{loc = Some l ; gas; _} :: _) as rtrace_expr when error -> - let extra = Trace.{loc = Some (Target.next_loc l); gas; stack = []} in - List.rev (extra :: rtrace_expr) - | _ -> trace_expr in - convert_trace ~loc_table trace_expr - - - let fail_of_err loc ~loc_table err = - let json = Ezjsonm.find err ["with"] in - let err_loc, _ (* failwith_ty *) = List.assoc loc loc_table in - let failed_with_expr = Json_encoding.destruct Target.const_encoding json in - let failed_with = decompile_const failed_with_expr |> Liquidity.const#ast in - err_loc, Some failed_with - - let error_trace_of_err loc ~loc_table err = - let err_loc, _ = List.assoc loc loc_table in - try - let json = Ezjsonm.find err ["trace"] in - let trace = trace_of_json ~loc_table ~error:true json in - err_loc, Some trace - with Not_found -> err_loc, None - - let raise_error_from_l ?loc_table ~original_json err_msg l = - let default_error () = - let last_descr = match List.rev l with - | (_, _, _, _, Some descr, _) :: _ -> "\n " ^ descr - | _ -> "" - in - let err_l = - List.map (fun (kind, id, _, title, descr, _) -> - match title with - | Some t -> t - | None -> Printf.sprintf "%s: %s" kind id - ) l - |> String.concat "\n- " + let err_l = + List.map (fun (kind, id, _, title, descr, _) -> + match title with + | Some t -> t + | None -> Printf.sprintf "%s: %s" kind id + ) l + |> String.concat "\n- " + in + Printf.sprintf "in %s\n- %s%s" err_msg err_l last_descr in - Printf.sprintf "in %s\n- %s%s" err_msg err_l last_descr - in - match loc_table with - | None -> raise (ResponseError (default_error (), original_json)) - | Some loc_table -> - let err_msg = Printf.sprintf "in %s" err_msg in + match loc_table with + | None -> raise (ResponseError (default_error (), original_json)) + | Some loc_table -> + let err_msg = Printf.sprintf "in %s" err_msg in + try + List.iter (fun (kind, id, loc, title, descr, err) -> + let is_rejected = + match String.rindex_opt id '.' with + | None -> false + | Some i -> + match String.sub id i (String.length id - i) with + | ".script_rejected" + | ".scriptRejectedRuntimeError" + | ".unhandled_user_exception" -> true + | _ -> false + in + match loc, is_rejected with + | Some loc, true -> + let err_loc, fail_v = fail_of_err loc ~loc_table err in + let _, trace = error_trace_of_err loc ~loc_table err in + raise ( + RuntimeFailure ( + (err_loc, err_msg), + fail_v, + Option.map TraceRepr.trace_to_trace_repr trace, + original_json)) + | Some loc, _ -> + let title = match title with Some t -> t | None -> id in + let err_msg = String.concat "\n- " [err_msg; title] in + let err_loc, trace = error_trace_of_err loc ~loc_table err in + raise ( + RuntimeError ( + (err_loc, err_msg), + Option.map TraceRepr.trace_to_trace_repr trace, + original_json)) + | _ -> () + ) l; + raise (ResponseError (default_error (), original_json)) + with Not_found -> raise (ResponseError (default_error (), original_json)) + + let extract_errors_from_json r schema = try - List.iter (fun (kind, id, loc, title, descr, err) -> - let is_rejected = - match String.rindex_opt id '.' with - | None -> false - | Some i -> - match String.sub id i (String.length id - i) with - | ".script_rejected" - | ".scriptRejectedRuntimeError" - | ".unhandled_user_exception" -> true - | _ -> false - in - match loc, is_rejected with - | Some loc, true -> - let err_loc, fail_v = fail_of_err loc ~loc_table err in - let _, trace = error_trace_of_err loc ~loc_table err in - raise (RuntimeFailure ((err_loc, err_msg), fail_v, trace, original_json)) - | Some loc, _ -> - let title = match title with Some t -> t | None -> id in - let err_msg = String.concat "\n- " [err_msg; title] in - let err_loc, trace = error_trace_of_err loc ~loc_table err in - raise (RuntimeError ((err_loc, err_msg), trace, original_json)) - | _ -> () - ) l; - raise (ResponseError (default_error (), original_json)) - with Not_found -> raise (ResponseError (default_error (), original_json)) - - let extract_errors_from_json r schema = - try - let schema_l = Ezjsonm.find schema ["oneOf"] in + let schema_l = Ezjsonm.find schema ["oneOf"] in + try + Ezjsonm.find r ["error"], schema_l + with Not_found -> + match Ezjsonm.get_list (fun x -> x) r with + | err :: _ -> + begin try + let r = Ezjsonm.find err ["ecoproto"] in + let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in + let schema_l = + schema_l + |> Ezjsonm.get_list (fun s -> + try + let s_id = + Ezjsonm.find s ["properties"; "id"; "enum"] + |> Ezjsonm.get_list Ezjsonm.get_string + |> function [s] -> s | _ -> assert false + in + if s_id <> id then + None + else + Some (Ezjsonm.find s + ["properties"; "ecoproto"; "items"; "oneOf"]) + with Not_found -> None + ) + |> List.find (function None -> false | Some _ -> true) + |> function None -> assert false | Some s -> s + in + r, schema_l + with Not_found -> r, schema_l + end + | [] -> r, schema_l + | exception Ezjsonm.Parse_error _ -> r, schema_l + with Not_found -> r, schema + + let rec descr_of_id id schema = try - Ezjsonm.find r ["error"], schema_l - with Not_found -> - match Ezjsonm.get_list (fun x -> x) r with - | err :: _ -> - begin try - let r = Ezjsonm.find err ["ecoproto"] in - let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in - let schema_l = - schema_l - |> Ezjsonm.get_list (fun s -> - try - let s_id = - Ezjsonm.find s ["properties"; "id"; "enum"] - |> Ezjsonm.get_list Ezjsonm.get_string - |> function [s] -> s | _ -> assert false - in - if s_id <> id then - None - else - Some (Ezjsonm.find s - ["properties"; "ecoproto"; "items"; "oneOf"]) + schema + |> Ezjsonm.get_list (fun s -> + try + let schema = Ezjsonm.find s ["oneOf"] in + descr_of_id id schema + with Not_found -> + try + let s_id = + Ezjsonm.find s ["properties"; "id"; "enum"] + |> Ezjsonm.get_list Ezjsonm.get_string + |> function [s] -> s | _ -> assert false + in + if s_id <> id then + None, None + else ( + let t = + try Some (Ezjsonm.find s ["title"] |> Ezjsonm.get_string) with Not_found -> None - ) - |> List.find (function None -> false | Some _ -> true) - |> function None -> assert false | Some s -> s - in - r, schema_l - with Not_found -> r, schema_l - end - | [] -> r, schema_l - | exception Ezjsonm.Parse_error _ -> r, schema_l - with Not_found -> r, schema - - let rec descr_of_id id schema = - try - schema - |> Ezjsonm.get_list (fun s -> - try - let schema = Ezjsonm.find s ["oneOf"] in - descr_of_id id schema - with Not_found -> - try - let s_id = - Ezjsonm.find s ["properties"; "id"; "enum"] - |> Ezjsonm.get_list Ezjsonm.get_string - |> function [s] -> s | _ -> assert false - in - if s_id <> id then + in + let d = + try Some (Ezjsonm.find s ["description"] |> Ezjsonm.get_string) + with Not_found -> None + in + (t, d) + ) + with Not_found -> None, None - else ( - let t = - try Some (Ezjsonm.find s ["title"] |> Ezjsonm.get_string) - with Not_found -> None - in - let d = - try Some (Ezjsonm.find s ["description"] |> Ezjsonm.get_string) - with Not_found -> None - in - (t, d) - ) - with Not_found -> - None, None - ) - |> List.find (function Some _, _ | _, Some _ -> true | _ -> false) - with Not_found | Ezjsonm.Parse_error _ -> - None, None + ) + |> List.find (function Some _, _ | _, Some _ -> true | _ -> false) + with Not_found | Ezjsonm.Parse_error _ -> + None, None (* let error_encoding = @@ -218,32 +332,40 @@ module Make (L : LANG) = struct (kind, id, loc, fail_with_json, trace_json)); ] *) - - let raise_response_error ?loc_table msg r = - Lazy.force error_schema >>= fun error_schema -> - let err, schema = extract_errors_from_json r error_schema in - let l = - try - Ezjsonm.get_list (fun err -> - let kind = Ezjsonm.find err ["kind"] |> Ezjsonm.get_string in - if kind = "generic" then begin - let err = Ezjsonm.find err ["error"] |> Ezjsonm.get_string in - raise (ResponseError (err, r)) - end; - let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in - let title, descr = descr_of_id id schema in - let loc = - try Some (Ezjsonm.find err ["location"] - |> Json_encoding.destruct Target.loc_encoding) - with Not_found -> - try Some (Ezjsonm.find err ["loc"] - |> Json_encoding.destruct Target.loc_encoding) - with Not_found -> None - in - kind, id, loc, title, descr, err - ) err - with Ezjsonm.Parse_error _ | Not_found -> [] - in - raise_error_from_l ?loc_table ~original_json:err msg l + let raise_response_error ?loc_table msg r = + Lazy.force error_schema >>= fun error_schema -> + let err, schema = extract_errors_from_json r error_schema in + let l = + try + Ezjsonm.get_list (fun err -> + let kind = Ezjsonm.find err ["kind"] |> Ezjsonm.get_string in + if kind = "generic" then begin + let err = Ezjsonm.find err ["error"] |> Ezjsonm.get_string in + raise (ResponseError (err, r)) + end; + let id = Ezjsonm.find err ["id"] |> Ezjsonm.get_string in + let title, descr = descr_of_id id schema in + let loc = + try Some (Ezjsonm.find err ["location"] + |> Json_encoding.destruct Target.loc_encoding) + with Not_found -> + try Some (Ezjsonm.find err ["loc"] + |> Json_encoding.destruct Target.loc_encoding) + with Not_found -> None + in + kind, id, loc, title, descr, err + ) err + with Ezjsonm.Parse_error _ | Not_found -> [] + in + raise_error_from_l ?loc_table ~original_json:err msg l + + end + + let () = + error_modules := (module Result : Err) :: !error_modules + + include Result + + end diff --git a/tools/client/liquidClientMain.ml b/tools/client/liquidClientMain.ml index d718af92..8bc18861 100644 --- a/tools/client/liquidClientMain.ml +++ b/tools/client/liquidClientMain.ml @@ -73,28 +73,24 @@ module Data = struct failwith (s ^ " is not a valid public key") end -let get_contract () = - From_files (Data.get_files ()) - |> Liquidity.parse_contract - |> Liquidity.contract#ast - -let get_inputs () = - Data.get_inputs () - |> List.map Liquidity.const#string +type err = + | Str of string + | Err of (LiquidTypes.location * string) let report_err ?(kind="Error") fmt (err_loc, err_msg) = - Format.fprintf fmt "%a: %s: @[%s@]\n%!" Liquidity.print_loc err_loc kind err_msg + Format.fprintf fmt "%a: %s: @[%s@]\n%!" Liquidity.print_loc err_loc kind err_msg -let report_error = function +let report_error = + function | LiquidError error -> report_err Format.err_formatter (error.err_loc, error.err_msg); | LiquidNamespace.Unknown_namespace (p, err_loc) as exn -> let backtrace = Printexc.get_backtrace () in Format.eprintf "Error: %s\nBacktrace:\n%s@." (Printexc.to_string exn) backtrace ; - report_err Format.err_formatter - (err_loc, - Printf.sprintf "Unknown module or contract %s" (String.concat "." p)); + report_err Format.err_formatter ( + err_loc, + Printf.sprintf "Unknown module or contract %s" (String.concat "." p)); | LiquidFromMicheline.Missing_program_field f -> Format.eprintf "Missing script field %s@." f; | LiquidClientRequest.RequestError (code, msg) -> @@ -104,6 +100,26 @@ let report_error = function if !LiquidOptions.verbosity > 0 then Format.eprintf "JSON Error:\n%s@." (Ezjsonm.value_to_string ~minify:false json); + | Failure f -> + Format.eprintf "Failure: %s@." f + | Syntaxerr.Error (Syntaxerr.Other loc) -> + report_err ~kind:"Syntax error" Format.err_formatter + (LiquidLoc.loc_of_location loc, "unknown"); + + | exn -> begin + try + LiquidClientErrors.report_err Format.err_formatter exn; + if !LiquidOptions.verbosity > 0 then + let json = LiquidClientErrors.error_json exn in + Format.eprintf "JSON Error:\n%s@." + (Ezjsonm.value_to_string ~minify:false json) + with + | LiquidClientErrors.UnknownException -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf "Error: %s\nBacktrace:\n%s@." + (Printexc.to_string exn) backtrace + end (* + | LiquidClientErrors.RuntimeError (error, _trace, json) -> report_err ~kind:"Runtime error" Format.err_formatter error; if !LiquidOptions.verbosity > 0 then @@ -114,26 +130,23 @@ let report_error = function if !LiquidOptions.verbosity > 0 then Format.eprintf "JSON Error:\n%s@." (Ezjsonm.value_to_string ~minify:false json); + | LiquidClientErrors.RuntimeFailure (error, None, _trace, json) -> report_err ~kind:"Failed at runtime" Format.err_formatter error; if !LiquidOptions.verbosity > 0 then Format.eprintf "JSON Error:\n%s@." (Ezjsonm.value_to_string ~minify:false json); + | LiquidClientErrors.RuntimeFailure (error, Some v, _trace, json) -> report_err ~kind:"Failed at runtime" Format.err_formatter error; - Format.eprintf "Failed with %s@." v#string; + Format.eprintf "Failed with %s@." v; if !LiquidOptions.verbosity > 0 then Format.eprintf "JSON Error:\n%s@." (Ezjsonm.value_to_string ~minify:false json); - | Failure f -> - Format.eprintf "Failure: %s@." f - | Syntaxerr.Error (Syntaxerr.Other loc) -> - report_err ~kind:"Syntax error" Format.err_formatter - (LiquidLoc.loc_of_location loc, "unknown"); | exn -> let backtrace = Printexc.get_backtrace () in Format.eprintf "Error: %s\nBacktrace:\n%s@." - (Printexc.to_string exn) backtrace + (Printexc.to_string exn) backtrace *) module type S = sig val inject : string -> unit @@ -152,6 +165,16 @@ module Make (L: LANG) : S = struct module Client = LiquidClient.Make(L) + + let get_contract () = + From_files (Data.get_files ()) + |> L.Source.parse_contract + |> L.Source.contract#ast + + let get_inputs () = + Data.get_inputs () + |> List.map L.Source.const#string + let inject file = let signature = match !LiquidOptions.signature with | None -> @@ -171,8 +194,8 @@ module Make (L: LANG) : S = struct let ops, r_storage, big_map_diff = Sync.run (get_contract ()) !Data.entry_name - (Liquidity.const#string !Data.parameter) - (Liquidity.const#string !Data.storage) + (L.Source.const#string !Data.parameter) + (L.Source.const#string !Data.storage) in Printf.printf "%s\n# Internal operations: %d\n%!" r_storage#string @@ -247,7 +270,7 @@ module Make (L: LANG) : S = struct Printf.printf "%s\n%!" r_storage#string let call_arg () = - let arg = !Data.parameter |> Liquidity.const#string in + let arg = !Data.parameter |> L.Source.const#string in let arg = Client.L.compile_const arg#ast |> Client.L.Target.const#ast in match !LiquidOptions.output with | None -> @@ -266,7 +289,7 @@ module Make (L: LANG) : S = struct ?contract ~address:!Data.contract_address ~entry:!Data.entry_name - (Liquidity.const#string !Data.parameter) + (L.Source.const#string !Data.parameter) in Printf.printf "Successful call to contract %s in operation %s\n%!" !Data.contract_address op_h @@ -280,7 +303,7 @@ module Make (L: LANG) : S = struct ?contract ~address:!Data.contract_address ~entry:!Data.entry_name - (Liquidity.const#string !Data.parameter) + (L.Source.const#string !Data.parameter) in Printf.eprintf "Raw operation:\n--------------\n%!"; Printf.printf "%s\n%!" Hex.(show @@ of_bytes op) @@ -292,20 +315,21 @@ module Make (L: LANG) : S = struct (get_contract ())#ast |> Client.L.compile_contract |> ignore); - let const = Liquidity.const#string !Data.const in - let ty = Liquidity.datatype#string !Data.ty in + let const = L.Source.const#string !Data.const in + let ty = L.Source.datatype#string !Data.ty in let bytes = Client.Sync.pack ~const ~ty in Printf.printf "0x%s\n%!" Hex.(show @@ of_bytes bytes) end - module MichelsonClient = Make(MichelsonTarget) module LoveClient = Make(LoveTarget) +module SolidityClient = Make(SolidityLang) let client () = match !LiquidOptions.target_lang with | Michelson_lang -> (module MichelsonClient : S) | Love_lang -> (module LoveClient : S) + | Solidity_lang -> (module SolidityClient : S) let parse_tez expl amount = match LiquidData.translate (LiquidFromParsetree.initial_env expl) diff --git a/tools/client/liquidClientRPCs.ml b/tools/client/liquidClientRPCs.ml index 2bf87d65..51298bec 100644 --- a/tools/client/liquidClientRPCs.ml +++ b/tools/client/liquidClientRPCs.ml @@ -154,7 +154,8 @@ module Make(L : LANG) = struct open E open T - let post ?loc_table ~input ~output ~path data = + let post + ?loc_table ~input ~output ~path data = post ~raise_response_error ?loc_table ~input ~output ~path data let get ?loc_table ~output ~path = diff --git a/tools/client/liquidClientSigs.ml b/tools/client/liquidClientSigs.ml index 527fba9d..2f9724d9 100644 --- a/tools/client/liquidClientSigs.ml +++ b/tools/client/liquidClientSigs.ml @@ -1,39 +1,53 @@ -module Liquidity = LiquidityLang - module type LANG = sig - (* module Source : sig - * type const - * (\* type expr *\) - * type contract - * type datatype - * type loc_info - * type location - * - * val unit : const - * val tuple : const list -> const - * val list_big_maps : const -> datatype -> (bm_id * datatype * datatype) list - * (\* val string_of_const : const -> string *\) - * val storage : contract -> datatype - * val entries : contract -> (string * datatype) list - * val apply_big_map_subst : (int * (const * const) list) list -> const -> const - * val default_empty_const : datatype -> const - * - * val print_loc : Format.formatter -> location -> unit - * - * val parse_contract : from -> contract - * - * val datatype : datatype Lazy_superposed.superposer - * val const : const Lazy_superposed.superposer - * val contract : contract Lazy_superposed.superposer - * - * (\**/* unsused **\) - * val const_encoding : const Json_encoding.encoding - * val contract_encoding : contract Json_encoding.encoding - * val datatype_encoding : datatype Json_encoding.encoding - * - * end *) + module Source : sig + type const + (* type expr *) + type contract + type datatype + type loc_info + type location + + type compiled_init = + | No_init + | Init_constant of const + | Init_code of contract * (string * datatype) list + | Init_components of (string * datatype) list + + val unit : const + val tuple : const list -> const + + val tunit : datatype + val ttuple : datatype list -> datatype + + val default_const : datatype -> const + + val list_big_maps : const -> datatype -> (LiquidClientUtils.bm_id * datatype * datatype) list + (* val string_of_const : const -> string *) + val storage : contract -> datatype + val entries : contract -> (string * datatype) list + val apply_big_map_subst : (int * (const * const) list) list -> const -> const + val default_empty_const : datatype -> const + + val print_loc : Format.formatter -> location -> unit + + val parse_contract : LiquidClientUtils.from -> contract + + val datatype : datatype Lazy_superposed.superposer + val const : const Lazy_superposed.superposer + val contract : contract Lazy_superposed.superposer + + val normalize_loc : location -> LiquidTypes.location + + val print_const : const -> string + + (**/* unsused **) + val const_encoding : const Json_encoding.encoding + val contract_encoding : contract Json_encoding.encoding + val datatype_encoding : datatype Json_encoding.encoding + + end module Target : sig type const @@ -59,16 +73,16 @@ module type LANG = sig end val compile_contract : - Liquidity.contract -> - Target.contract * Liquidity.compiled_init * - (Target.location * (Liquidity.location * Liquidity.loc_info)) list + Source.contract -> + Target.contract * Source.compiled_init * + (Target.location * (Source.location * Source.loc_info)) list - val decompile_contract : Target.contract -> Liquidity.contract + val decompile_contract : Target.contract -> Source.contract - val compile_const : ?ty:Liquidity.datatype -> Liquidity.const -> Target.const + val compile_const : ?ty:Source.datatype -> Source.const -> Target.const - val decompile_const : ?ty:Liquidity.datatype -> Target.const -> Liquidity.const + val decompile_const : ?ty:Source.datatype -> Target.const -> Source.const - val compile_datatype : Liquidity.datatype -> Target.datatype + val compile_datatype : Source.datatype -> Target.datatype end diff --git a/tools/client/liquidClientTypes.ml b/tools/client/liquidClientTypes.ml index 0cc37725..75a201c9 100644 --- a/tools/client/liquidClientTypes.ml +++ b/tools/client/liquidClientTypes.ml @@ -137,7 +137,6 @@ module Trace = struct (req "stack" (list (obj2 (req "item" const_enc) (opt "annot" string))))) - end module Big_map_diff = struct diff --git a/tools/client/liquidClientUtils.ml b/tools/client/liquidClientUtils.ml index 04f1018f..1168f4b7 100644 --- a/tools/client/liquidClientUtils.ml +++ b/tools/client/liquidClientUtils.ml @@ -112,3 +112,12 @@ let case_ignore_extra enc proj inj = | None -> None | Some x -> Some (x, ())) (fun (x, ()) -> inj x) + +module Option = struct + type 'a t = 'a option + + let map (f : 'a -> 'b) (elt : 'a t) : 'b t = + match elt with + | None -> None + | Some e -> Some (f e) +end diff --git a/tools/client/liquidTraceRepr.ml b/tools/client/liquidTraceRepr.ml new file mode 100644 index 00000000..2bd3fcfc --- /dev/null +++ b/tools/client/liquidTraceRepr.ml @@ -0,0 +1,53 @@ +open LiquidClientSigs +open LiquidClientTypes +open LiquidClientUtils + +module type S = sig + val length : int + val max_gas : int + val end_gas : int + + val item_gas : int -> int + val item_loc : int -> LiquidTypes.location option + val item_str_stack_map : (string * string option -> 'a) -> int -> 'a list +end + +type t = (module S) + +module MakeTrace(L : LANG) = struct + let trace_to_trace_repr t : (module S) = + let array = Array.of_list t in ( + module struct + let length = Array.length array + let item_gas i = array.(i).Trace.gas + + let max_gas = item_gas 0 + let end_gas = item_gas length + + let item_loc i = Option.map L.Source.normalize_loc array.(i).loc + + let item_str_stack_map f i = + List.map + (fun (c, str) -> f (c#string, str)) + (array.(i).stack) + end + ) +end + +let length (t : t) = + let module T = (val t) in T.length + +let max_gas (t : t) = + let module T = (val t) in T.max_gas + +let end_gas (t : t) = + let module T = (val t) in T.end_gas + +let item_gas (pos : int) (t : t) = + let module T = (val t) in T.item_gas pos + +let item_loc (pos : int) (t : t) = + let module T = (val t) in T.item_loc pos + +let item_str_stack_map f (pos : int) (t : t) = + let module T = (val t) in T.item_str_stack_map f pos diff --git a/tools/client/liquidTraceRepr.mli b/tools/client/liquidTraceRepr.mli new file mode 100644 index 00000000..371b7617 --- /dev/null +++ b/tools/client/liquidTraceRepr.mli @@ -0,0 +1,20 @@ +type t + +val length : t -> int + +val max_gas : t -> int + +val end_gas : t -> int + +val item_gas : int -> t -> int + +val item_loc : int -> t -> LiquidTypes.location option + +val item_str_stack_map : (string * string option -> 'a) -> int -> t -> 'a list + +module MakeTrace(L : LiquidClientSigs.LANG) : +sig + val trace_to_trace_repr : + (L.Source.location, L.Source.const Lazy_superposed.t) + LiquidClientTypes.Trace.trace_item list -> t +end diff --git a/tools/client/liquidityLang.ml b/tools/client/liquidityLang.ml index 1dbbb59e..20e518f2 100644 --- a/tools/client/liquidityLang.ml +++ b/tools/client/liquidityLang.ml @@ -16,6 +16,13 @@ type compiled_init = let unit = CUnit let tuple l = CTuple l + +let tunit = Tunit +let ttuple l = Ttuple l + +let default_const (ty : datatype) : const = + LiquidUntype.untype_const (LiquidData.default_const ty) + let print_loc = LiquidLoc.print_loc let rec list_big_maps name acc storage storage_ty = @@ -225,3 +232,5 @@ let datatype = new Lazy_superposed.superposer (object method print = print_datatype method encoding = datatype_encoding end) + +let normalize_loc l = l diff --git a/tools/client/loveTarget.ml b/tools/client/loveTarget.ml index 678c5fd8..a40ac48a 100644 --- a/tools/client/loveTarget.ml +++ b/tools/client/loveTarget.ml @@ -8,6 +8,8 @@ open Love_ast_types module Liquidity = LiquidityLang +module Source = Liquidity + module Target = struct open Dune_Network_Lib @@ -138,6 +140,7 @@ end include Compiler module Client = LiquidClient.Make(struct + module Source = Source module Target = Target include Compiler end) diff --git a/tools/client/michelsonTarget.ml b/tools/client/michelsonTarget.ml index 65c3cab8..1274ba1e 100644 --- a/tools/client/michelsonTarget.ml +++ b/tools/client/michelsonTarget.ml @@ -4,6 +4,8 @@ open Dune_Network_Lib module Liquidity = LiquidityLang +module Source = Liquidity + module Target = struct open Dune_Network_Lib.Micheline @@ -182,7 +184,7 @@ end include Compiler module Client = LiquidClient.Make(struct - module Target = Target - include Compiler - end - ) + module Source = Source + module Target = Target + include Compiler +end) diff --git a/tools/client/solidityLang.ml b/tools/client/solidityLang.ml new file mode 100644 index 00000000..36d72401 --- /dev/null +++ b/tools/client/solidityLang.ml @@ -0,0 +1,222 @@ +open Tezos_protocol_sol.Protocol +open Solidity_ast +open Solidity_common +open Tezos_data_encoding +open LiquidClientUtils + +module Lang = struct + + exception NoAssociatedConstant of Solidity_ast.type_ + + type const = Solidity_ast.constant + + type contract = Solidity_ast.program + + type datatype = Solidity_ast.type_ list + + type location = Solidity_common.loc + + type loc_info = string option + + type compiled_init = + | No_init + | Init_constant of const + | Init_code of contract * (string * datatype) list + | Init_components of (string * datatype) list + + let name = "Solidity" + + let unit = Solidity_ast.CTuple [] + + let tuple l = Solidity_ast.CTuple l + + let tunit = [] + + let ttuple l = + List.map + (function + | [t] -> t + | _ -> failwith "Solidity.ttuple: bad type") l + + let default_const ty = + let default = function + | ElementaryType e -> begin + match e with + | TypeBool -> CBool true + | TypeInt size + | TypeUint size + | TypeFixed (size, _) + | TypeUfixed (size, _) -> CNumber (Q.zero, Unit, size) + | TypeAddress _ | TypeBytes _ -> CAddress Contract_repr.zero + | TypeString -> CString "" + end + | Array (_, _) -> CArray [] + | Mapping _ -> failwith "Mapping has no associated const" + | FunctionType _ -> failwith "Function type has no associated const" + | UserDefinedType _ -> failwith "User Defined Type has no associated const" in + match List.map default ty with + | [c] -> c + | l -> tuple l + + let list_big_maps (storage : const) (storage_ty : datatype) = + [] (* No bigmaps in Solidity yet *) + + let storage _contract = tunit (* No representation *) + + let return_to_typ_return ((typ, stor, _) : Solidity_ast.return) = (typ, stor) + + + let entries (contract : contract) = + let module V = Solidity_visitor in + let vis = object + inherit V.Ast.init_ast_visitor + + val mutable ctrct : string = "" + + val mutable res : (string * datatype) list = [] + + method getRes () = res + + method! visitContractDef c = + let () = ctrct <- Solidity_common.Ident.to_string c.contract_name.contents in + DoChildren + + method! visitFunctionDef fd = + match fd.fun_mutability with + | MNonPayable | MPayable -> + let ty = Solidity_ast.FunctionType { + fun_type_params = fd.fun_params; + fun_type_returns = List.map return_to_typ_return fd.fun_returns; + fun_type_visibility = fd.fun_visibility; + fun_type_mutability = fd.fun_mutability + } in + let name = + Format.sprintf + "%s.%s" + ctrct + (Solidity_common.Ident.to_string fd.fun_name.contents) in + res <- (name, [ty]) :: res; + SkipChildren + | MView | MPure -> SkipChildren + end in + let () = + V.Ast.visitProgram + (vis :> V.Ast.ast_visitor) + contract in + vis#getRes () + + let apply_big_map_subst _ c = c (* No bigmaps yet *) + + let default_empty_const t = match t with + | Solidity_ast.ElementaryType e -> begin + match e with + | Solidity_common.TypeBool -> Solidity_ast.CBool true + | TypeInt size + | TypeUint size + | TypeFixed (size, _) + | TypeUfixed (size, _) -> CNumber (Q.zero, Unit, size) + | TypeAddress _ -> CAddress (Contract_repr.zero) + | TypeBytes _ -> raise (NoAssociatedConstant t) + | TypeString -> CString "__default_solidity_string__" + end + | Array _ -> CArray [] + | Mapping _ + | FunctionType _ + | UserDefinedType _ -> raise (NoAssociatedConstant t) + + let default_empty_const (t : datatype) : const = + match List.map default_empty_const t with + | [c] -> c + | l -> tuple l + + let print_loc fmt ((l1, c1), (l2, c2)) = + Format.fprintf fmt "%d.%d-%d.%d" l1 c1 l2 c2 + + let parse_const _ = failwith "TODO: parse_const" + + let parse_contract _ = failwith "TODO: parse_contract" + + let parse_datatype _ = failwith "TODO: parse datatype" + + let const_encoding = Solidity_json_encoding.value_encoding + + let contract_encoding = Solidity_json_encoding.SourceAst.code_encoding + + let (const_encoding : const Json_encoding.encoding) = + Json_encoding.conv + (fun _ -> failwith "Solidity.const_encoding unimplemented") + (fun _ -> failwith "Solidity.const_encoding unimplemented") + Json_encoding.unit + + let (contract_encoding : contract Json_encoding.encoding) = + Json_encoding.conv + (fun _ -> failwith "Solidity.contract_encoding unimplemented") + (fun _ -> failwith "Solidity.contract_encoding unimplemented") + Json_encoding.unit + + let (datatype_encoding : datatype Json_encoding.encoding) = + Json_encoding.conv + (fun _ -> failwith "Solidity.datatype_encoding unimplemented") + (fun _ -> failwith "Solidity.datatype_encoding unimplemented") + Json_encoding.unit + + let print_datatype t = + String.concat "," @@ List.map Solidity_printer.SourceAst.string_of_type t + + let print_const c = + Solidity_printer.string_of_constant c + + let print_contract c = Solidity_printer.SourceAst.string_of_code c + + let datatype = new Lazy_superposed.superposer (object + method parse = parse_datatype + method print = print_datatype + method encoding = datatype_encoding + end) + + let const = new Lazy_superposed.superposer (object + method parse = parse_const + method print = print_const + method encoding = const_encoding + end) + + let contract = new Lazy_superposed.superposer (object + method parse = parse_contract + method print = print_contract + method encoding = contract_encoding + end) + + let normalize_loc (l : loc) = LiquidTypes.{ + loc_file = "solidity_project"; + loc_pos = Some l + } + + let loc_encoding = + let pair = Json_encoding.(tup2 int int) in + Json_encoding.tup2 pair pair + + let next_loc ((_, _), (l2, _)) = + (l2 + 1, 1), (l2 + 1, 2) + + let compareXX cmp (c1, c1') (c2, c2') = + let c = cmp c1 c2 in + if c = 0 then + cmp c1' c2' + else c + + let compare_loc (l1 : loc) (l2 : loc) = + compareXX (compareXX (-)) l1 l2 +end + +module Source = Lang +module Target = Lang + +let compile_contract c = + c, Source.No_init, [] + +let decompile_contract c = c + +let compile_const ?ty c = ignore ty; c +let decompile_const ?ty c = ignore ty; c + +let compile_datatype t = t diff --git a/tools/liquidity/liquidFromParsetree.ml b/tools/liquidity/liquidFromParsetree.ml index 645eba23..c01b23a4 100644 --- a/tools/liquidity/liquidFromParsetree.ml +++ b/tools/liquidity/liquidFromParsetree.ml @@ -2199,7 +2199,8 @@ and translate_structure env acc ast : syntax_exp parsed_struct = error_loc prim_loc "Top-level identifier %S already defined" prim_name; let tvs, atys, rtys = match !LiquidOptions.target_lang with | Michelson_lang -> translate_ext_type env prim_type - | Love_lang -> translate_ext_type_love env prim_type in + | Love_lang -> translate_ext_type_love env prim_type + | Solidity_lang -> failwith "No solidity compilation from Liquidity" in let valid_in_external = function | Trecord _ | Tsum _ | Tclosure _ | Tfail | Ttuple (_ :: _ :: _ :: _) -> error_loc prim_loc @@ -2210,7 +2211,8 @@ and translate_structure env acc ast : syntax_exp parsed_struct = | Michelson_lang -> List.iter valid_in_external atys; List.iter valid_in_external rtys; - | Love_lang -> () + | Love_lang -> () + | Solidity_lang -> failwith "TODO" ); let effect = List.exists (fun (a, _) -> a.txt = "effect") prim_attr in let nb_arg = List.length atys in diff --git a/tools/liquidity/liquidMain.ml b/tools/liquidity/liquidMain.ml index 407cbf85..c1d1d749 100644 --- a/tools/liquidity/liquidMain.ml +++ b/tools/liquidity/liquidMain.ml @@ -368,6 +368,7 @@ let compile_liquid_files files = match !LiquidOptions.target_lang with | Michelson_lang -> compile_liquid_files_to_michelson files | Love_lang -> compile_liquid_files_to_love files + | Solidity_lang -> failwith "Todo: compile_liquid_files" module Data = struct let files = ref [] diff --git a/tools/liquidity/liquidOptions.ml b/tools/liquidity/liquidOptions.ml index c972b4ec..656fd180 100644 --- a/tools/liquidity/liquidOptions.ml +++ b/tools/liquidity/liquidOptions.ml @@ -36,6 +36,7 @@ let verbosity = type target_lang = | Love_lang | Michelson_lang + | Solidity_lang let target_lang = ref Michelson_lang