modify proto-alpha
This commit is contained in:
parent
4b4c450b9a
commit
b197c30299
@ -65,6 +65,13 @@ module Script_timestamp = struct
|
||||
Raw_context.current_timestamp ctxt
|
||||
|> Timestamp.to_seconds
|
||||
|> of_int64
|
||||
|
||||
let set_now ctxt timestamp =
|
||||
timestamp
|
||||
|> to_zint
|
||||
|> Z.to_int64
|
||||
|> Time.of_seconds
|
||||
|> (Raw_context.set_current_timestamp ctxt)
|
||||
end
|
||||
module Script = struct
|
||||
include Michelson_v1_primitives
|
||||
|
@ -178,6 +178,7 @@ module Script_timestamp : sig
|
||||
val add_delta: t -> z num -> t
|
||||
val sub_delta: t -> z num -> t
|
||||
val now: context -> t
|
||||
val set_now: context -> t -> context
|
||||
val to_zint: t -> Z.t
|
||||
val of_zint: Z.t -> t
|
||||
end
|
||||
@ -248,6 +249,7 @@ module Script : sig
|
||||
| I_NEQ
|
||||
| I_NIL
|
||||
| I_NONE
|
||||
| I_NOP
|
||||
| I_NOT
|
||||
| I_NOW
|
||||
| I_OR
|
||||
|
@ -93,6 +93,7 @@ type prim =
|
||||
| I_NEQ
|
||||
| I_NIL
|
||||
| I_NONE
|
||||
| I_NOP
|
||||
| I_NOT
|
||||
| I_NOW
|
||||
| I_OR
|
||||
@ -226,6 +227,7 @@ let string_of_prim = function
|
||||
| I_NEQ -> "NEQ"
|
||||
| I_NIL -> "NIL"
|
||||
| I_NONE -> "NONE"
|
||||
| I_NOP -> "NOP"
|
||||
| I_NOT -> "NOT"
|
||||
| I_NOW -> "NOW"
|
||||
| I_OR -> "OR"
|
||||
@ -340,6 +342,7 @@ let prim_of_string = function
|
||||
| "NEQ" -> ok I_NEQ
|
||||
| "NIL" -> ok I_NIL
|
||||
| "NONE" -> ok I_NONE
|
||||
| "NOP" -> ok I_NOP
|
||||
| "NOT" -> ok I_NOT
|
||||
| "NOW" -> ok I_NOW
|
||||
| "OR" -> ok I_OR
|
||||
|
@ -91,6 +91,7 @@ type prim =
|
||||
| I_NEQ
|
||||
| I_NIL
|
||||
| I_NONE
|
||||
| I_NOP
|
||||
| I_NOT
|
||||
| I_NOW
|
||||
| I_OR
|
||||
|
@ -51,6 +51,7 @@ type root_context = t
|
||||
|
||||
let current_level ctxt = ctxt.level
|
||||
let current_timestamp ctxt = ctxt.timestamp
|
||||
let set_current_timestamp ctxt timestamp = { ctxt with timestamp }
|
||||
let current_fitness ctxt = ctxt.fitness
|
||||
let first_level ctxt = ctxt.first_level
|
||||
let constants ctxt = ctxt.constants
|
||||
|
@ -80,6 +80,7 @@ val recover: context -> Context.t
|
||||
|
||||
val current_level: context -> Level_repr.t
|
||||
val current_timestamp: context -> Time.t
|
||||
val set_current_timestamp: context -> Time.t -> context
|
||||
|
||||
val current_fitness: context -> Int64.t
|
||||
val set_current_fitness: context -> Int64.t -> t
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -61,3 +61,27 @@ val trace:
|
||||
parameter: Script.expr ->
|
||||
amount: Tez.t ->
|
||||
(execution_result * execution_trace) tzresult Lwt.t
|
||||
|
||||
val interp:
|
||||
(?log: execution_trace ref ->
|
||||
context ->
|
||||
source: Contract.t -> payer:Contract.t -> self: Contract.t -> Tez.t ->
|
||||
('p, 'r) Script_typed_ir.lambda -> 'p ->
|
||||
('r * context) tzresult Lwt.t)
|
||||
|
||||
type 'tys stack =
|
||||
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack
|
||||
| Empty : Script_typed_ir.end_of_stack stack
|
||||
|
||||
type ex_descr_stack = Ex_descr_stack : (('a, 'b) Script_typed_ir.descr * 'a stack) -> ex_descr_stack
|
||||
|
||||
val step:
|
||||
?log:execution_trace ref ->
|
||||
context ->
|
||||
source:Contract.t ->
|
||||
self:Contract.t ->
|
||||
payer:Contract.t ->
|
||||
?visitor: (ex_descr_stack -> unit) ->
|
||||
Tez.t -> ('b, 'a) Script_typed_ir.descr
|
||||
-> 'b stack
|
||||
-> ('a stack * context) tzresult Lwt.t
|
||||
|
@ -36,6 +36,7 @@ module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse
|
||||
type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty
|
||||
type ex_ty = Ex_ty : 'a ty -> ex_ty
|
||||
type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty
|
||||
type ex_typed_value = Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
|
||||
|
||||
type tc_context =
|
||||
| Lambda : tc_context
|
||||
@ -322,6 +323,7 @@ let namespace = function
|
||||
| I_NIL
|
||||
| I_NONE
|
||||
| I_NOT
|
||||
| I_NOP
|
||||
| I_NOW
|
||||
| I_OR
|
||||
| I_PAIR
|
||||
@ -2968,150 +2970,173 @@ let typecheck_data
|
||||
(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)
|
||||
|
||||
let rec unparse_data
|
||||
: type a. context -> unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
||||
= fun ctxt mode ty a ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
||||
match ty, a with
|
||||
| Unit_t _, () ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_Unit, [], []), ctxt)
|
||||
| Int_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| Nat_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| String_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
|
||||
return (String (-1, s), ctxt)
|
||||
| Bytes_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, s), ctxt)
|
||||
| Bool_t _, true ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_True, [], []), ctxt)
|
||||
| Bool_t _, false ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_False, [], []), ctxt)
|
||||
| Timestamp_t _, t ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Readable ->
|
||||
match Script_timestamp.to_notation t with
|
||||
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Some s -> return (String (-1, s), ctxt)
|
||||
end
|
||||
| Address_t _, c ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Contract_t _, (_, c) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Signature_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.to_b58check s), ctxt)
|
||||
end
|
||||
| Mutez_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
|
||||
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
|
||||
| Key_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
|
||||
end
|
||||
| Key_hash_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
||||
end
|
||||
| Operation_t _, op ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
||||
| Union_t ((tl, _), _, _), L l ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode tl l >>=? fun (l, ctxt) ->
|
||||
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
||||
| Union_t (_, (tr, _), _), R r ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
||||
| Option_t ((t, _), _, _), Some v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode t v >>=? fun (v, ctxt) ->
|
||||
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
||||
| Option_t _, None ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_None, [], []), ctxt)
|
||||
| List_t (t, _), items ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) element ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode t element >>=? fun (unparsed, ctxt) ->
|
||||
return (unparsed :: l, ctxt))
|
||||
([], ctxt)
|
||||
items >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, List.rev items), ctxt)
|
||||
| Set_t (t, _), set ->
|
||||
let t = ty_of_comparable_ty t in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode t item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt)
|
||||
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Map_t (kt, vt, _), map ->
|
||||
let kt = ty_of_comparable_ty kt in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) (k, v) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||
unparse_data ctxt mode kt k >>=? fun (key, ctxt) ->
|
||||
unparse_data ctxt mode vt v >>=? fun (value, ctxt) ->
|
||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||
([], ctxt)
|
||||
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Big_map_t (_kt, _kv, _), _map ->
|
||||
return (Micheline.Seq (-1, []), ctxt)
|
||||
| Lambda_t _, Lam (_, original_code) ->
|
||||
unparse_code ctxt mode (root original_code)
|
||||
: type a. context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t) ->
|
||||
unparsing_mode -> a ty -> a -> (Script.node * context) tzresult Lwt.t
|
||||
= fun ctxt ?(mapper = fun _ -> return None) mode ty a ->
|
||||
mapper (Ex_typed_value (ty, a)) >>=? function
|
||||
| Some s -> return (s, ctxt)
|
||||
| None -> (
|
||||
let unparse_same ctxt ty a = unparse_data ctxt ~mapper mode ty a in
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.cycle) >>=? fun ctxt ->
|
||||
match ty, a with
|
||||
| Unit_t _, () ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.unit) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_Unit, [], []), ctxt)
|
||||
| Int_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| Nat_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.int v)) >>=? fun ctxt ->
|
||||
return (Int (-1, Script_int.to_zint v), ctxt)
|
||||
| String_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.string s)) >>=? fun ctxt ->
|
||||
return (String (-1, s), ctxt)
|
||||
| Bytes_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, s), ctxt)
|
||||
| Bool_t _, true ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_True, [], []), ctxt)
|
||||
| Bool_t _, false ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.bool) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_False, [], []), ctxt)
|
||||
| Timestamp_t _, t ->
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t)) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Readable ->
|
||||
match Script_timestamp.to_notation t with
|
||||
| None -> return (Int (-1, Script_timestamp.to_zint t), ctxt)
|
||||
| Some s -> return (String (-1, s), ctxt)
|
||||
end
|
||||
| Address_t _, c ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Contract_t _, (_, c) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.contract) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Contract.encoding c in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable -> return (String (-1, Contract.to_b58check c), ctxt)
|
||||
end
|
||||
| Signature_t _, s ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.signature) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.to_b58check s), ctxt)
|
||||
end
|
||||
| Mutez_t _, v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.tez) >>=? fun ctxt ->
|
||||
return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
|
||||
| Key_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key.to_b58check k), ctxt)
|
||||
end
|
||||
| Key_hash_t _, k ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.key_hash) >>=? fun ctxt ->
|
||||
begin
|
||||
match mode with
|
||||
| Optimized ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Signature.Public_key_hash.encoding k in
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Readable ->
|
||||
return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt)
|
||||
end
|
||||
| Operation_t _, op ->
|
||||
let bytes = Data_encoding.Binary.to_bytes_exn Operation.internal_operation_encoding op in
|
||||
Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes)) >>=? fun ctxt ->
|
||||
return (Bytes (-1, bytes), ctxt)
|
||||
| Pair_t ((tl, _, _), (tr, _, _), _), (l, r) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.pair) >>=? fun ctxt ->
|
||||
unparse_same ctxt tl l >>=? fun (l, ctxt) ->
|
||||
unparse_same ctxt tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Pair, [ l; r ], []), ctxt)
|
||||
| Union_t ((tl, _), _, _), L l ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_same ctxt tl l >>=? fun (l, ctxt) ->
|
||||
return (Prim (-1, D_Left, [ l ], []), ctxt)
|
||||
| Union_t (_, (tr, _), _), R r ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.union) >>=? fun ctxt ->
|
||||
unparse_same ctxt tr r >>=? fun (r, ctxt) ->
|
||||
return (Prim (-1, D_Right, [ r ], []), ctxt)
|
||||
| Option_t ((t, _), _, _), Some v ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.some) >>=? fun ctxt ->
|
||||
unparse_same ctxt t v >>=? fun (v, ctxt) ->
|
||||
return (Prim (-1, D_Some, [ v ], []), ctxt)
|
||||
| Option_t _, None ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.none) >>=? fun ctxt ->
|
||||
return (Prim (-1, D_None, [], []), ctxt)
|
||||
| List_t (t, _), items ->
|
||||
fold_left_s
|
||||
(fun (l, ctxt) element ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.list_element) >>=? fun ctxt ->
|
||||
unparse_same ctxt t element >>=? fun (unparsed, ctxt) ->
|
||||
return (unparsed :: l, ctxt))
|
||||
([], ctxt)
|
||||
items >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, List.rev items), ctxt)
|
||||
| Set_t (t, _), set ->
|
||||
let t = ty_of_comparable_ty t in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) item ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.set_element) >>=? fun ctxt ->
|
||||
unparse_same ctxt t item >>=? fun (item, ctxt) ->
|
||||
return (item :: l, ctxt))
|
||||
([], ctxt)
|
||||
(set_fold (fun e acc -> e :: acc) set []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Map_t (kt, vt, _), map ->
|
||||
let kt = ty_of_comparable_ty kt in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) (k, v) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||
unparse_same ctxt kt k >>=? fun (key, ctxt) ->
|
||||
unparse_same ctxt vt v >>=? fun (value, ctxt) ->
|
||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||
([], ctxt)
|
||||
(map_fold (fun k v acc -> (k, v) :: acc) map []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, items), ctxt)
|
||||
| Big_map_t (kt, vt, _), map ->
|
||||
if false then (
|
||||
let kt = ty_of_comparable_ty kt in
|
||||
fold_left_s
|
||||
(fun (l, ctxt) (k, v) ->
|
||||
Lwt.return (Gas.consume ctxt Unparse_costs.map_element) >>=? fun ctxt ->
|
||||
match v with
|
||||
| None -> return (l, ctxt)
|
||||
| Some v -> (
|
||||
unparse_same ctxt kt k >>=? fun (key, ctxt) ->
|
||||
unparse_same ctxt vt v >>=? fun (value, ctxt) ->
|
||||
return (Prim (-1, D_Elt, [ key ; value ], []) :: l, ctxt))
|
||||
)
|
||||
([], ctxt)
|
||||
(map_fold (fun k v acc -> (k, v) :: acc) map.diff []) >>=? fun (items, ctxt) ->
|
||||
return (Micheline.Seq (-1, String (-1, "...") :: items), ctxt)
|
||||
) else (
|
||||
return (Micheline.Seq (-1, []), ctxt)
|
||||
)
|
||||
| Lambda_t _, Lam (_, original_code) ->
|
||||
unparse_code ctxt mode (root original_code)
|
||||
)
|
||||
|
||||
(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
|
||||
and unparse_code ctxt mode = function
|
||||
|
@ -32,12 +32,15 @@ type ex_comparable_ty = Ex_comparable_ty : 'a Script_typed_ir.comparable_ty -> e
|
||||
type ex_ty = Ex_ty : 'a Script_typed_ir.ty -> ex_ty
|
||||
type ex_stack_ty = Ex_stack_ty : 'a Script_typed_ir.stack_ty -> ex_stack_ty
|
||||
type ex_script = Ex_script : ('a, 'b) Script_typed_ir.script -> ex_script
|
||||
type ex_typed_value = Ex_typed_value : ('a Script_typed_ir.ty * 'a) -> ex_typed_value
|
||||
|
||||
type unparsing_mode = Optimized | Readable
|
||||
|
||||
type type_logger =
|
||||
int -> (Script.expr * Script.annot) list -> (Script.expr * Script.annot) list -> unit
|
||||
|
||||
val ty_of_comparable_ty : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.ty
|
||||
|
||||
(* ---- Sets and Maps -------------------------------------------------------*)
|
||||
|
||||
val empty_set : 'a Script_typed_ir.comparable_ty -> 'a Script_typed_ir.set
|
||||
@ -77,12 +80,19 @@ val ty_eq :
|
||||
'ta Script_typed_ir.ty -> 'tb Script_typed_ir.ty ->
|
||||
(('ta Script_typed_ir.ty, 'tb Script_typed_ir.ty) eq * context) tzresult
|
||||
|
||||
val stack_ty_eq :
|
||||
context -> int ->
|
||||
'ta Script_typed_ir.stack_ty -> 'tb Script_typed_ir.stack_ty ->
|
||||
(('ta Script_typed_ir.stack_ty, 'tb Script_typed_ir.stack_ty) eq * context) tzresult
|
||||
|
||||
val parse_data :
|
||||
?type_logger: type_logger ->
|
||||
context ->
|
||||
'a Script_typed_ir.ty -> Script.node -> ('a * context) tzresult Lwt.t
|
||||
|
||||
val unparse_data :
|
||||
context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a ->
|
||||
context -> ?mapper:(ex_typed_value -> Script.node option tzresult Lwt.t)
|
||||
-> unparsing_mode -> 'a Script_typed_ir.ty -> 'a ->
|
||||
(Script.node * context) tzresult Lwt.t
|
||||
|
||||
val parse_ty :
|
||||
@ -94,6 +104,30 @@ val parse_ty :
|
||||
val unparse_ty :
|
||||
context -> 'a Script_typed_ir.ty -> (Script.node * context) tzresult Lwt.t
|
||||
|
||||
val parse_storage_ty :
|
||||
context ->
|
||||
Script.node -> (ex_ty * context) tzresult
|
||||
|
||||
type tc_context =
|
||||
| Lambda : tc_context
|
||||
| Dip : 'a Script_typed_ir.stack_ty * tc_context -> tc_context
|
||||
| Toplevel : { storage_type : 'sto Script_typed_ir.ty ; param_type : 'param Script_typed_ir.ty } -> tc_context
|
||||
|
||||
type 'bef judgement =
|
||||
| Typed : ('bef, 'aft) Script_typed_ir.descr -> 'bef judgement
|
||||
| Failed : { descr : 'aft. 'aft Script_typed_ir.stack_ty -> ('bef, 'aft) Script_typed_ir.descr } -> 'bef judgement
|
||||
|
||||
val parse_instr :
|
||||
?type_logger: type_logger ->
|
||||
tc_context -> context ->
|
||||
Script.node -> 'bef Script_typed_ir.stack_ty -> ('bef judgement * context) tzresult Lwt.t
|
||||
|
||||
val parse_returning :
|
||||
?type_logger: type_logger ->
|
||||
tc_context -> context ->
|
||||
'arg Script_typed_ir.ty * Script_typed_ir.var_annot option -> 'ret Script_typed_ir.ty -> Script.node ->
|
||||
(('arg, 'ret) Script_typed_ir.lambda * context) tzresult Lwt.t
|
||||
|
||||
val parse_toplevel :
|
||||
Script.expr -> (Script.node * Script.node * Script.node) tzresult
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user