Add pp can assert_value_eq for Literal_op
This commit is contained in:
Pierre-Emmanuel Wulfman
parent
429a1dc412
commit
c2e4f2f36d
@ -1,5 +1,59 @@
|
||||
open Types
|
||||
|
||||
open Memory_proto_alpha.Protocol.Alpha_context
|
||||
let assert_operation_eq (a: packed_internal_operation) (b: packed_internal_operation): unit option =
|
||||
let Internal_operation {source=sa; operation=oa; nonce=na} = a in
|
||||
let Internal_operation {source=sb; operation=ob; nonce=nb} = b in
|
||||
let assert_source_eq sa sb =
|
||||
let sa = Contract.to_b58check sa in
|
||||
let sb = Contract.to_b58check sb in
|
||||
if String.equal sa sb then Some () else None
|
||||
in
|
||||
let rec assert_param_eq (pa,pb) =
|
||||
let open Tezos_micheline.Micheline in
|
||||
match (pa, pb) with
|
||||
| Int (la, ia), Int (lb, ib) when la = lb && ia = ib -> Some ()
|
||||
| String (la, sa), String (lb, sb) when la = lb && sa = sb -> Some ()
|
||||
| Bytes (la, ba), Bytes (lb, bb) when la = lb && ba = bb -> Some ()
|
||||
| Prim (la, pa, nla, aa), Prim (lb, pb, nlb, ab) when la = lb && pa = pb ->
|
||||
let la = List.map assert_param_eq @@ List.combine nla nlb in
|
||||
let lb = List.map ( fun (sa,sb) ->
|
||||
if String.equal sa sb then Some () else None) @@
|
||||
List.combine aa ab
|
||||
in
|
||||
Option.map (fun _ -> ()) @@ Option.bind_list @@ la @ lb
|
||||
| Seq (la, nla), Seq (lb, nlb) when la = lb ->
|
||||
Option.map (fun _ -> ()) @@ Option.bind_list @@ List.map assert_param_eq @@
|
||||
List.combine nla nlb
|
||||
| _ -> None
|
||||
in
|
||||
let assert_operation_eq (type a b) (oa: a manager_operation) (ob: b manager_operation) =
|
||||
match (oa, ob) with
|
||||
| Reveal sa, Reveal sb when sa = sb -> Some ()
|
||||
| Reveal _, _ -> None
|
||||
| Transaction ta, Transaction tb ->
|
||||
let aa,pa,ea,da = ta.amount,ta.parameters,ta.entrypoint,ta.destination in
|
||||
let ab,pb,eb,db = tb.amount,tb.parameters,tb.entrypoint,tb.destination in
|
||||
Format.printf "amount : %b; p : %b, e: %b, d : %b\n" (aa=ab) (pa=pb) (ea=eb) (da=db) ;
|
||||
let (pa,pb) = Tezos_data_encoding.Data_encoding.(force_decode pa, force_decode pb) in
|
||||
Option.bind (fun _ -> Some ()) @@
|
||||
Option.bind_list [
|
||||
Option.bind (fun (pa,pb) -> assert_param_eq Tezos_micheline.Micheline.(root pa, root pb)) @@
|
||||
Option.bind_pair (pa,pb);
|
||||
if aa = ab && ea = eb && da = db then Some () else None ]
|
||||
| Transaction _, _ -> None
|
||||
| Origination _oa, Origination _ob -> Some ()
|
||||
| Origination _, _ -> None
|
||||
| Delegation da, Delegation db when da = db -> Some ()
|
||||
| Delegation _, _ -> None
|
||||
in
|
||||
let assert_nonce_eq na nb = if na = nb then Some () else None in
|
||||
Option.bind (fun _ -> Some ()) @@
|
||||
Option.bind_list [
|
||||
assert_source_eq sa sb;
|
||||
assert_operation_eq oa ob;
|
||||
assert_nonce_eq na nb]
|
||||
|
||||
let assert_literal_eq (a, b : literal * literal) : unit option =
|
||||
match (a, b) with
|
||||
| Literal_int a, Literal_int b when a = b -> Some ()
|
||||
@ -27,7 +81,7 @@ let assert_literal_eq (a, b : literal * literal) : unit option =
|
||||
| Literal_address a, Literal_address b when a = b -> Some ()
|
||||
| Literal_address _, Literal_address _ -> None
|
||||
| Literal_address _, _ -> None
|
||||
| Literal_operation _, Literal_operation _ -> None
|
||||
| Literal_operation opa, Literal_operation opb -> assert_operation_eq opa opb
|
||||
| Literal_operation _, _ -> None
|
||||
| Literal_signature a, Literal_signature b when a = b -> Some ()
|
||||
| Literal_signature _, Literal_signature _ -> None
|
||||
|
||||
@ -130,6 +130,57 @@ let constant ppf : constant' -> unit = function
|
||||
| C_CONVERT_FROM_RIGHT_COMB -> fprintf ppf "CONVERT_FROM_RIGHT_COMB"
|
||||
| C_CONVERT_FROM_LEFT_COMB -> fprintf ppf "CONVERT_FROM_LEFT_COMB"
|
||||
|
||||
let operation ppf (o : Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation) : unit =
|
||||
let print_option f ppf o =
|
||||
match o with
|
||||
Some (s) -> fprintf ppf "%a" f s
|
||||
| None -> fprintf ppf "None"
|
||||
in
|
||||
let open Tezos_micheline.Micheline in
|
||||
let rec prim ppf (node : (_,Memory_proto_alpha.Protocol.Alpha_context.Script.prim) node)= match node with
|
||||
| Int (l , i) -> fprintf ppf "Int (%i, %a)" l Z.pp_print i
|
||||
| String (l , s) -> fprintf ppf "String (%i, %s)" l s
|
||||
| Bytes (l, b) -> fprintf ppf "B (%i, %s)" l (Bytes.to_string b)
|
||||
| Prim (l , p , nl, a) -> fprintf ppf "P (%i, %s, %a, %a)" l
|
||||
(Memory_proto_alpha.Protocol.Michelson_v1_primitives.string_of_prim p)
|
||||
(list_sep_d prim) nl
|
||||
(list_sep_d (fun ppf s -> fprintf ppf "%s" s)) a
|
||||
| Seq (l, nl) -> fprintf ppf "S (%i, %a)" l
|
||||
(list_sep_d prim) nl
|
||||
in
|
||||
let l ppf (l: Memory_proto_alpha.Protocol.Alpha_context.Script.lazy_expr) =
|
||||
let oo = Tezos_data_encoding.Data_encoding.force_decode l in
|
||||
match oo with
|
||||
Some o -> fprintf ppf "%a" prim (Tezos_micheline.Micheline.root o)
|
||||
| None -> fprintf ppf "Fail decoding"
|
||||
in
|
||||
|
||||
let op ppf (type a) : a Memory_proto_alpha.Protocol.Alpha_context.manager_operation -> unit = function
|
||||
| Reveal (s: Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key.t) ->
|
||||
fprintf ppf "R %a" Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key.pp s
|
||||
| Transaction {amount; parameters; entrypoint; destination} ->
|
||||
fprintf ppf "T {%a; %a; %s; %a}"
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.pp amount
|
||||
l parameters
|
||||
entrypoint
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Contract.pp destination
|
||||
|
||||
| Origination {delegate; script; credit; preorigination} ->
|
||||
fprintf ppf "O {%a; %a; %a; %a}"
|
||||
(print_option Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key_hash.pp) delegate
|
||||
l script.code
|
||||
Memory_proto_alpha.Protocol.Alpha_context.Tez.pp credit
|
||||
(print_option Memory_proto_alpha.Protocol.Alpha_context.Contract.pp) preorigination
|
||||
|
||||
| Delegation so ->
|
||||
fprintf ppf "D %a" (print_option Tezos_protocol_environment_006_PsCARTHA__Environment.Signature.Public_key_hash.pp) so
|
||||
in
|
||||
let Internal_operation {source;operation;nonce} = o in
|
||||
fprintf ppf "{source: %s; operation: %a; nonce: %i"
|
||||
(Memory_proto_alpha.Protocol.Alpha_context.Contract.to_b58check source)
|
||||
op operation
|
||||
nonce
|
||||
|
||||
let literal ppf (l : literal) =
|
||||
match l with
|
||||
| Literal_unit -> fprintf ppf "unit"
|
||||
@ -141,7 +192,7 @@ let literal ppf (l : literal) =
|
||||
| Literal_string s -> fprintf ppf "%a" Ligo_string.pp s
|
||||
| Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b)
|
||||
| Literal_address s -> fprintf ppf "@%S" s
|
||||
| Literal_operation _ -> fprintf ppf "Operation(...bytes)"
|
||||
| Literal_operation o -> fprintf ppf "Operation(%a)" operation o
|
||||
| Literal_key s -> fprintf ppf "key %s" s
|
||||
| Literal_key_hash s -> fprintf ppf "key_hash %s" s
|
||||
| Literal_signature s -> fprintf ppf "Signature %s" s
|
||||
|
||||
Loading…
Reference in New Issue
Block a user