Source file apply_results.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Data_encoding

let error_encoding =
  def
    "error"
    ~description:
      "The full list of RPC errors would be too long to include.\n\
       It is available at RPC `/errors` (GET).\n\
       Errors specific to protocol Alpha have an id that starts with \
       `proto.alpha`."
  @@ splitted
       ~json:
         (conv
            (fun err ->
              Data_encoding.Json.construct Error_monad.error_encoding err)
            (fun json ->
              Data_encoding.Json.destruct Error_monad.error_encoding json)
            json)
       ~binary:Error_monad.error_encoding

type _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

type packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

type 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

type packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

module Manager_result = struct
  type 'kind case =
    | MCase : {
        op_case : 'kind Operation.Encoding.Manager_operations.case;
        encoding : 'a Data_encoding.t;
        kind : 'kind Kind.manager;
        iselect :
          packed_internal_operation_result ->
          ('kind internal_operation * 'kind manager_operation_result) option;
        select :
          packed_successful_manager_operation_result ->
          'kind successful_manager_operation_result option;
        proj : 'kind successful_manager_operation_result -> 'a;
        inj : 'a -> 'kind successful_manager_operation_result;
        t : 'kind manager_operation_result Data_encoding.t;
      }
        -> 'kind case

  let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
    let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
    let t =
      def (Format.asprintf "operation.alpha.operation_result.%s" name)
      @@ union
           ~tag_size:`Uint8
           [ case
               (Tag 0)
               ~title:"Applied"
               (merge_objs (obj1 (req "status" (constant "applied"))) encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Backtracked _ ->
                     None
                 | Applied o -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some ((), proj o) ))
               (fun ((), x) -> Applied (inj x));
             case
               (Tag 1)
               ~title:"Failed"
               (obj2
                  (req "status" (constant "failed"))
                  (req "errors" (list error_encoding)))
               (function Failed (_, errs) -> Some ((), errs) | _ -> None)
               (fun ((), errs) -> Failed (kind, errs));
             case
               (Tag 2)
               ~title:"Skipped"
               (obj1 (req "status" (constant "skipped")))
               (function Skipped _ -> Some () | _ -> None)
               (fun () -> Skipped kind);
             case
               (Tag 3)
               ~title:"Backtracked"
               (merge_objs
                  (obj2
                     (req "status" (constant "backtracked"))
                     (opt "errors" (list error_encoding)))
                  encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Applied _ ->
                     None
                 | Backtracked (o, errs) -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some (((), errs), proj o) ))
               (fun (((), errs), x) -> Backtracked (inj x, errs)) ]
    in
    MCase {op_case; encoding; kind; iselect; select; proj; inj; t}

  let reveal_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.reveal_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Reveal_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Reveal_manager_kind
      ~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Reveal_result {consumed_gas})

  let transaction_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.transaction_case
      ~encoding:
        (obj8
           (opt "storage" Script.expr_encoding)
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero)
           (dft "allocated_destination_contract" bool false))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Transaction_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Transaction_manager_kind
      ~proj:(function
        | Transaction_result
            { storage;
              big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff;
              allocated_destination_contract } ->
            ( storage,
              big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff,
              allocated_destination_contract ))
      ~inj:
        (fun ( storage,
               big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff,
               allocated_destination_contract ) ->
        Transaction_result
          {
            storage;
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
            allocated_destination_contract;
          })

  let origination_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.origination_case
      ~encoding:
        (obj6
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Origination_result _ as op) ->
            Some op
        | _ ->
            None)
      ~proj:(function
        | Origination_result
            { big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff } ->
            ( big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff ))
      ~kind:Kind.Origination_manager_kind
      ~inj:
        (fun ( big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff ) ->
        Origination_result
          {
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
          })

  let delegation_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.delegation_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Delegation _; _} as op), res)
          ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Delegation_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Delegation_manager_kind
      ~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
end

let internal_operation_result_encoding :
    packed_internal_operation_result Data_encoding.t =
  let make (type kind)
      (Manager_result.MCase res_case : kind Manager_result.case) =
    let (Operation.Encoding.Manager_operations.MCase op_case) =
      res_case.op_case
    in
    case
      (Tag op_case.tag)
      ~title:op_case.name
      (merge_objs
         (obj3
            (req "kind" (constant op_case.name))
            (req "source" Contract.encoding)
            (req "nonce" uint16))
         (merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
      (fun op ->
        match res_case.iselect op with
        | Some (op, res) ->
            Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
        | None ->
            None)
      (fun (((), source, nonce), (op, res)) ->
        let op = {source; operation = op_case.inj op; nonce} in
        Internal_operation_result (op, res))
  in
  def "operation.alpha.internal_operation_result"
  @@ union
       [ make Manager_result.reveal_case;
         make Manager_result.transaction_case;
         make Manager_result.origination_case;
         make Manager_result.delegation_case ]

type 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

type packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

type packed_contents_and_result =
  | Contents_and_result :
      'kind Operation.contents * 'kind contents_result
      -> packed_contents_and_result

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_kind :
    type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
 fun ka kb ->
  match (ka, kb) with
  | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
      Some Eq
  | (Kind.Reveal_manager_kind, _) ->
      None
  | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
      Some Eq
  | (Kind.Transaction_manager_kind, _) ->
      None
  | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
      Some Eq
  | (Kind.Origination_manager_kind, _) ->
      None
  | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
      Some Eq
  | (Kind.Delegation_manager_kind, _) ->
      None

module Encoding = struct
  type 'kind case =
    | Case : {
        op_case : 'kind Operation.Encoding.case;
        encoding : 'a Data_encoding.t;
        select : packed_contents_result -> 'kind contents_result option;
        mselect :
          packed_contents_and_result ->
          ('kind contents * 'kind contents_result) option;
        proj : 'kind contents_result -> 'a;
        inj : 'a -> 'kind contents_result;
      }
        -> 'kind case

  let tagged_case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  let endorsement_case =
    Case
      {
        op_case = Operation.Encoding.endorsement_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "delegate" Signature.Public_key_hash.encoding)
            (req "slots" (list uint8));
        select =
          (function
          | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Endorsement _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj =
          (function
          | Endorsement_result {balance_updates; delegate; slots} ->
              (balance_updates, delegate, slots));
        inj =
          (fun (balance_updates, delegate, slots) ->
            Endorsement_result {balance_updates; delegate; slots});
      }

  let seed_nonce_revelation_case =
    Case
      {
        op_case = Operation.Encoding.seed_nonce_revelation_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Seed_nonce_revelation_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Seed_nonce_revelation_result bus) -> bus);
        inj = (fun bus -> Seed_nonce_revelation_result bus);
      }

  let double_endorsement_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_endorsement_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_endorsement_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence_result bus) -> bus);
        inj = (fun bus -> Double_endorsement_evidence_result bus);
      }

  let double_baking_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_baking_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_baking_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_baking_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_baking_evidence_result bus) -> bus);
        inj = (fun bus -> Double_baking_evidence_result bus);
      }

  let activate_account_case =
    Case
      {
        op_case = Operation.Encoding.activate_account_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Activate_account_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Activate_account _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Activate_account_result bus) -> bus);
        inj = (fun bus -> Activate_account_result bus);
      }

  let proposals_case =
    Case
      {
        op_case = Operation.Encoding.proposals_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Proposals_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Proposals _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Proposals_result -> ());
        inj = (fun () -> Proposals_result);
      }

  let ballot_case =
    Case
      {
        op_case = Operation.Encoding.ballot_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Ballot_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Ballot _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Ballot_result -> ());
        inj = (fun () -> Ballot_result);
      }

  let make_manager_case (type kind)
      (Operation.Encoding.Case op_case :
        kind Kind.manager Operation.Encoding.case)
      (Manager_result.MCase res_case : kind Manager_result.case) mselect =
    Case
      {
        op_case = Operation.Encoding.Case op_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "operation_result" res_case.t)
            (dft
               "internal_operation_results"
               (list internal_operation_result_encoding)
               []);
        select =
          (function
          | Contents_result
              (Manager_operation_result
                ({operation_result = Applied res; _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Applied res})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Backtracked (res, errs); _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Backtracked (res, errs)})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Skipped kind; _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Skipped kind}) )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Failed (kind, errs); _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Failed (kind, errs)}) )
          | Contents_result Ballot_result ->
              None
          | Contents_result (Endorsement_result _) ->
              None
          | Contents_result (Seed_nonce_revelation_result _) ->
              None
          | Contents_result (Double_endorsement_evidence_result _) ->
              None
          | Contents_result (Double_baking_evidence_result _) ->
              None
          | Contents_result (Activate_account_result _) ->
              None
          | Contents_result Proposals_result ->
              None);
        mselect;
        proj =
          (fun (Manager_operation_result
                 { balance_updates = bus;
                   operation_result = r;
                   internal_operation_results = rs }) ->
            (bus, r, rs));
        inj =
          (fun (bus, r, rs) ->
            Manager_operation_result
              {
                balance_updates = bus;
                operation_result = r;
                internal_operation_results = rs;
              });
      }

  let reveal_case =
    make_manager_case
      Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let transaction_case =
    make_manager_case
      Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let origination_case =
    make_manager_case
      Operation.Encoding.origination_case
      Manager_result.origination_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let delegation_case =
    make_manager_case
      Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Delegation _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
end

let contents_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; _};
          encoding;
          mselect = _;
          select;
          proj;
          inj }) =
    let proj x =
      match select x with None -> None | Some x -> Some (proj x)
    in
    let inj x = Contents_result (inj x) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.contents_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

let contents_and_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
          mselect;
          encoding = meta_encoding;
          proj = meta_proj;
          inj = meta_inj;
          _ }) =
    let proj c =
      match mselect c with
      | Some (op, res) ->
          Some (proj op, meta_proj res)
      | _ ->
          None
    in
    let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
    let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.operation_contents_and_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

type 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

type packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

let contents_result_list_encoding =
  let rec to_list = function
    | Contents_result_list (Single_result o) ->
        [Contents_result o]
    | Contents_result_list (Cons_result (o, os)) ->
        Contents_result o :: to_list (Contents_result_list os)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty operation result"
    | [Contents_result o] ->
        Contents_result_list (Single_result o)
    | Contents_result o :: os -> (
        let (Contents_result_list os) = of_list os in
        match (o, os) with
        | ( Manager_operation_result _,
            Single_result (Manager_operation_result _) ) ->
            Contents_result_list (Cons_result (o, os))
        | (Manager_operation_result _, Cons_result _) ->
            Contents_result_list (Cons_result (o, os))
        | _ ->
            Pervasives.failwith "cannot decode ill-formed operation result" )
  in
  def "operation.alpha.contents_list_result"
  @@ conv to_list of_list (list contents_result_encoding)

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

let contents_and_result_list_encoding =
  let rec to_list = function
    | Contents_and_result_list (Single_and_result (op, res)) ->
        [Contents_and_result (op, res)]
    | Contents_and_result_list (Cons_and_result (op, res, rest)) ->
        Contents_and_result (op, res)
        :: to_list (Contents_and_result_list rest)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty combined operation result"
    | [Contents_and_result (op, res)] ->
        Contents_and_result_list (Single_and_result (op, res))
    | Contents_and_result (op, res) :: rest -> (
        let (Contents_and_result_list rest) = of_list rest in
        match (op, rest) with
        | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | (Manager_operation _, Cons_and_result (_, _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | _ ->
            Pervasives.failwith
              "cannot decode ill-formed combined operation result" )
  in
  conv to_list of_list (Variable.list contents_and_result_encoding)

type 'kind operation_metadata = {contents : 'kind contents_result_list}

type packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

let operation_metadata_encoding =
  def "operation.alpha.result"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_metadata"
           contents_result_list_encoding
           (function
             | Operation_metadata {contents} ->
                 Some (Contents_result_list contents)
             | _ ->
                 None)
           (fun (Contents_result_list contents) ->
             Operation_metadata {contents});
         case
           (Tag 1)
           ~title:"No_operation_metadata"
           empty
           (function No_operation_metadata -> Some () | _ -> None)
           (fun () -> No_operation_metadata) ]

let kind_equal :
    type kind kind2.
    kind contents -> kind2 contents_result -> (kind, kind2) eq option =
 fun op res ->
  match (op, res) with
  | (Endorsement _, Endorsement_result _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence_result _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account_result _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals_result) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot_result) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result {operation_result = Applied (Reveal_result _); _}
    ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Backtracked (Reveal_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
    ) ->
      Some Eq
  | (Manager_operation {operation = Reveal _; _}, _) ->
      None
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Applied (Transaction_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Backtracked (Transaction_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Transaction_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Transaction _; _}, _) ->
      None
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Applied (Origination_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Backtracked (Origination_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Origination_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Origination _; _}, _) ->
      None
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Applied (Delegation_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Backtracked (Delegation_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Delegation_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Delegation _; _}, _) ->
      None

let rec kind_equal_list :
    type kind kind2.
    kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
    =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) -> (
    match kind_equal op res with None -> None | Some Eq -> Some Eq )
  | (Cons (op, ops), Cons_result (res, ress)) -> (
    match kind_equal op res with
    | None ->
        None
    | Some Eq -> (
      match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
  | _ ->
      None

let rec pack_contents_list :
    type kind.
    kind contents_list ->
    kind contents_result_list ->
    kind contents_and_result_list =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) ->
      Single_and_result (op, res)
  | (Cons (op, ops), Cons_result (res, ress)) ->
      Cons_and_result (op, res, pack_contents_list ops ress)
  | ( Single (Manager_operation _),
      Cons_result (Manager_operation_result _, Single_result _) ) ->
      .
  | ( Cons (_, _),
      Single_result (Manager_operation_result {operation_result = Failed _; _})
    ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Skipped _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Applied _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Backtracked _; _}) ) ->
      .
  | (Single _, Cons_result _) ->
      .

let rec unpack_contents_list :
    type kind.
    kind contents_and_result_list ->
    kind contents_list * kind contents_result_list = function
  | Single_and_result (op, res) ->
      (Single op, Single_result res)
  | Cons_and_result (op, res, rest) ->
      let (ops, ress) = unpack_contents_list rest in
      (Cons (op, ops), Cons_result (res, ress))

let rec to_list = function
  | Contents_result_list (Single_result o) ->
      [Contents_result o]
  | Contents_result_list (Cons_result (o, os)) ->
      Contents_result o :: to_list (Contents_result_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents_result o] ->
      Contents_result_list (Single_result o)
  | Contents_result o :: os -> (
      let (Contents_result_list os) = of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        ->
          Contents_result_list (Cons_result (o, os))
      | (Manager_operation_result _, Cons_result _) ->
          Contents_result_list (Cons_result (o, os))
      | _ ->
          Pervasives.failwith
            "Operation result list of length > 1 should only contains manager \
             operations result." )

let operation_data_and_metadata_encoding =
  def "operation.alpha.operation_with_metadata"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_with_metadata"
           (obj2
              (req "contents" (dynamic_size contents_and_result_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data _, No_operation_metadata) ->
                 None
             | (Operation_data op, Operation_metadata res) -> (
               match kind_equal_list op.contents res.contents with
               | None ->
                   Pervasives.failwith
                     "cannot decode inconsistent combined operation result"
               | Some Eq ->
                   Some
                     ( Contents_and_result_list
                         (pack_contents_list op.contents res.contents),
                       op.signature ) ))
           (fun (Contents_and_result_list contents, signature) ->
             let (op_contents, res_contents) = unpack_contents_list contents in
             ( Operation_data {contents = op_contents; signature},
               Operation_metadata {contents = res_contents} ));
         case
           (Tag 1)
           ~title:"Operation_without_metadata"
           (obj2
              (req "contents" (dynamic_size Operation.contents_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data op, No_operation_metadata) ->
                 Some (Contents_list op.contents, op.signature)
             | (Operation_data _, Operation_metadata _) ->
                 None)
           (fun (Contents_list contents, signature) ->
             (Operation_data {contents; signature}, No_operation_metadata)) ]

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

let block_metadata_encoding =
  let open Data_encoding in
  def "block_header.alpha.metadata"
  @@ conv
       (fun { baker;
              level;
              voting_period_kind;
              nonce_hash;
              consumed_gas;
              deactivated;
              balance_updates } ->
         ( baker,
           level,
           voting_period_kind,
           nonce_hash,
           consumed_gas,
           deactivated,
           balance_updates ))
       (fun ( baker,
              level,
              voting_period_kind,
              nonce_hash,
              consumed_gas,
              deactivated,
              balance_updates ) ->
         {
           baker;
           level;
           voting_period_kind;
           nonce_hash;
           consumed_gas;
           deactivated;
           balance_updates;
         })
       (obj7
          (req "baker" Signature.Public_key_hash.encoding)
          (req "level" Level.encoding)
          (req "voting_period_kind" Voting_period.kind_encoding)
          (req "nonce_hash" (option Nonce_hash.encoding))
          (req "consumed_gas" (check_size 10 n))
          (req "deactivated" (list Signature.Public_key_hash.encoding))
          (req "balance_updates" Delegate.balance_updates_encoding))