Alpha: add a type for operation results

src/proto_alpha/lib_client/client_proto_context.ml

@@ -12,6 +12,7 @@ open Alpha_context
 open Tezos_micheline
 open Client_proto_contracts
 open Client_keys
+open Apply_operation_result
 
 let get_balance (rpc : #Proto_alpha.rpc_context) block contract =
   Alpha_services.Contract.balance rpc block contract
@@ -36,15 +37,17 @@ let parse_expression arg =
     (Micheline_parser.no_parsing_error
        (Michelson_v1_parser.parse_expression arg))
 
-let pp_internal_operation ppf { source ; operation } =
+let pp_manager_operation_content ppf source operation internal pp_result result =
   Format.fprintf ppf "@[<v 0>" ;
   begin match operation with
     | Alpha_context.Transaction { destination ; amount ; parameters } ->
         Format.fprintf ppf
-          "@[<v 2>Transaction:@,\
+          "@[<v 2>%s:@,\
-           Of: %a@,\
+           Amount: %s%a@,\
            From: %a@,\
            To: %a"
+          (if internal then "Internal transaction" else "Transaction")
+          Client_proto_args.tez_sym
           Tez.pp amount
           Contract.pp source
           Contract.pp destination ;
@@ -55,21 +58,24 @@ let pp_internal_operation ppf { source ; operation } =
                 "@,Parameter: @[<v 0>%a@]"
                 Michelson_v1_printer.print_expr expr
         end ;
+        pp_result ppf result ;
         Format.fprintf ppf "@]" ;
     | Origination { manager ; delegate ; credit ; spendable ; delegatable ; script } ->
-        Format.fprintf ppf "@[<v 2>Origination:@,\
+        Format.fprintf ppf "@[<v 2>%s:@,\
                             From: %a@,\
                             For: %a@,\
-                            Credit: %a"
+                            Credit: %s%a"
+          (if internal then "Internal origination" else "Origination")
           Contract.pp source
           Signature.Public_key_hash.pp manager
+          Client_proto_args.tez_sym
           Tez.pp credit ;
         begin match script with
           | None -> Format.fprintf ppf "@,No script (accepts all transactions)"
           | Some { code ; storage } ->
               Format.fprintf ppf
-                "@,@[<v 2>Script:@,%a\
+                "@,@[<hv 2>Script:@ %a\
-                 @,@[<v 2>Initial storage:@,%a@]"
+                 @,@[<hv 2>Initial storage:@ %a@]"
                 Michelson_v1_printer.print_expr code
                 Michelson_v1_printer.print_expr storage
         end ;
@@ -79,30 +85,327 @@ let pp_internal_operation ppf { source ; operation } =
         end ;
         if spendable then Format.fprintf ppf "@,Spendable by its manager" ;
         if delegatable then Format.fprintf ppf "@,Delegate can be changed later" ;
+        pp_result ppf result ;
         Format.fprintf ppf "@]" ;
     | Reveal key ->
         Format.fprintf ppf
-          "@[<v 2>Revelation of manager public key:@,\
+          "@[<v 2>%s of manager public key:@,\
            Contract: %a@,\
-           Key: %a@]"
+           Key: %a%a@]"
+          (if internal then "Internal revelation" else "Revelation")
           Contract.pp source
           Signature.Public_key.pp key
+          pp_result result
     | Delegation None ->
         Format.fprintf ppf
-          "@[<v 2>Delegation:@,\
+          "@[<v 2>%s:@,\
            Contract: %a@,\
-           To: nobody@]"
+           To: nobody%a@]"
+          (if internal then "Internal Delegation" else "Delegation")
           Contract.pp source
+          pp_result result
     | Delegation (Some delegate) ->
         Format.fprintf ppf
-          "@[<v 2>Delegation:@,\
+          "@[<v 2>%s:@,\
            Contract: %a@,\
-           To: %a@]"
+           To: %a%a@]"
+          (if internal then "Internal Delegation" else "Delegation")
           Contract.pp source
           Signature.Public_key_hash.pp delegate
+          pp_result result
   end ;
   Format.fprintf ppf "@]"
 
+let pp_balance_updates ppf = function
+  | [] -> ()
+  | balance_updates ->
+      let balance_updates =
+        List.map (fun (balance, update) ->
+            let balance = match balance with
+              | Contract c ->
+                  Format.asprintf "%a" Contract.pp c
+              | Rewards (pkh, l) ->
+                  Format.asprintf "rewards(%a,%a)"
+                    Signature.Public_key_hash.pp pkh Cycle.pp l
+              | Fees (pkh, l) ->
+                  Format.asprintf "fees(%a,%a)"
+                    Signature.Public_key_hash.pp pkh Cycle.pp l
+              | Deposits (pkh, l) ->
+                  Format.asprintf "deposits(%a,%a)"
+                    Signature.Public_key_hash.pp pkh Cycle.pp l in
+            (balance, update)) balance_updates in
+      let column_size =
+        List.fold_left
+          (fun acc (balance, _) -> Compare.Int.max acc (String.length balance))
+          0 balance_updates in
+      let pp_update ppf = function
+        | Credited amount -> Format.fprintf ppf "+%s%a" Client_proto_args.tez_sym Tez.pp amount
+        | Debited amount -> Format.fprintf ppf "-%s%a" Client_proto_args.tez_sym Tez.pp amount in
+      let pp_one ppf (balance, update) =
+        let to_fill = column_size + 3 - String.length balance in
+        let filler = String.make to_fill '.' in
+        Format.fprintf ppf "%s %s %a" balance filler pp_update update in
+      Format.fprintf ppf "@[<v 0>%a@]"
+        (Format.pp_print_list pp_one) balance_updates
+
+let pp_operation_result ppf ({ contents ; _ }, operation_result) =
+  Format.fprintf ppf "@[<v 0>" ;
+  begin match contents, operation_result with
+    | Anonymous_operations ops, Anonymous_operations_result rs ->
+        let ops_rs = List.combine ops rs in
+        let pp_anonymous_operation_result ppf = function
+          | Seed_nonce_revelation { level ; nonce },
+            Seed_nonce_revelation_result bus ->
+              Format.fprintf ppf
+                "@[<v 2>Seed nonce revelation:@,\
+                 Level: %a@,\
+                 Nonce (hash): %a@,\
+                 Balance updates:@,\
+                \  %a@]"
+                Raw_level.pp level
+                Nonce_hash.pp (Nonce.hash nonce)
+                pp_balance_updates bus
+          | Double_baking_evidence { bh1 ; bh2 },
+            Double_baking_evidence_result bus ->
+              Format.fprintf ppf
+                "@[<v 2>Double baking evidence:@,\
+                 Exhibit A: %a@,\
+                 Exhibit B: %a@,\
+                 Balance updates:@,\
+                \  %a@]"
+                Block_hash.pp (Block_header.hash bh1)
+                Block_hash.pp (Block_header.hash bh2)
+                pp_balance_updates bus
+          | Double_endorsement_evidence { op1 ; op2},
+            Double_endorsement_evidence_result bus ->
+              Format.fprintf ppf
+                "@[<v 2>Double endorsement evidence:@,\
+                 Exhibit A: %a@,\
+                 Exhibit B: %a@,\
+                 Balance updates:@,\
+                \  %a@]"
+                Operation_hash.pp (Operation.hash op1)
+                Operation_hash.pp (Operation.hash op2)
+                pp_balance_updates bus
+          | Activation { id ; _ },
+            Activation_result bus ->
+              Format.fprintf ppf
+                "@[<v 2>Genesis account activation:@,\
+                 Account: %a@,\
+                 Balance updates:@,\
+                \  %a@]"
+                Ed25519.Public_key_hash.pp id
+                pp_balance_updates bus
+          | _, _ -> invalid_arg "Apply_operation_result.pp"
+        in
+        Format.pp_print_list pp_anonymous_operation_result ppf ops_rs
+    | Sourced_operations
+        (Consensus_operation
+           (Endorsements { block ; level ; slots })),
+      Sourced_operation_result
+        (Consensus_operation_result
+           (Endorsements_result (delegate, _slots))) ->
+        Format.fprintf ppf
+          "@[<v 2>Endorsement:@,\
+           Block: %a@,\
+           Level: %a@,\
+           Delegate: %a@,\
+           Slots: %a@]"
+          Block_hash.pp block
+          Raw_level.pp level
+          Signature.Public_key_hash.pp delegate
+          (Format.pp_print_list
+             ~pp_sep:Format.pp_print_space
+             Format.pp_print_int)
+          slots
+    | Sourced_operations
+        (Amendment_operation { source ; operation = Proposals { period ; proposals } }),
+      Sourced_operation_result Amendment_operation_result ->
+        Format.fprintf ppf
+          "@[<v 2>Proposals:@,\
+           From: %a@,\
+           Period: %a@,\
+           Protocols:@,\
+          \  @[<v 0>%a@]@]"
+          Signature.Public_key_hash.pp source
+          Voting_period.pp period
+          (Format.pp_print_list Protocol_hash.pp) proposals
+    | Sourced_operations
+        (Amendment_operation { source ; operation = Ballot { period ; proposal ; ballot } }),
+      Sourced_operation_result Amendment_operation_result ->
+        Format.fprintf ppf
+          "@[<v 2>Ballot:@,\
+           From: %a@,\
+           Period: %a@,\
+           Protocol: %a@,\
+           Vote: %s@]"
+          Signature.Public_key_hash.pp source
+          Voting_period.pp period
+          Protocol_hash.pp proposal
+          (match ballot with Yay -> "YAY" | Pass -> "PASS" | Nay -> "NAY")
+    | Sourced_operations (Dictator_operation (Activate protocol)),
+      Sourced_operation_result Dictator_operation_result ->
+        Format.fprintf ppf
+          "@[<v 2>Dictator protocol activation:@,\
+           Protocol: %a@]"
+          Protocol_hash.pp protocol
+    | Sourced_operations (Dictator_operation (Activate_testchain protocol)),
+      Sourced_operation_result Dictator_operation_result ->
+        Format.fprintf ppf
+          "@[<v 2>Dictator test protocol activation:@,\
+           Protocol: %a@]"
+          Protocol_hash.pp protocol
+    | Sourced_operations (Manager_operations { source ; fee ; counter ; operations ; gas_limit }),
+      Sourced_operation_result (Manager_operations_result { balance_updates ; operation_results }) ->
+        let pp_result ppf result =
+          Format.fprintf ppf "@," ;
+          match result with
+          | Skipped ->
+              Format.fprintf ppf
+                "This operation was skipped"
+          | Failed errs ->
+              Format.fprintf ppf
+                "@[<v 2>This operation FAILED with the folllowing error:@,%a@]"
+                (Format.pp_print_list Alpha_environment.Error_monad.pp) errs
+          | Applied Reveal_result ->
+              Format.fprintf ppf
+                "This revelation was successfully applied"
+          | Applied Delegation_result ->
+              Format.fprintf ppf
+                "This delegation was successfully applied"
+          | Applied (Transaction_result { balance_updates ; consumed_gas ;
+                                          operations ; storage ;
+                                          originated_contracts ; storage_fees_increment }) ->
+              Format.fprintf ppf
+                "This transaction was successfully applied" ;
+              begin match operations with
+                | [] -> ()
+                | ops -> Format.fprintf ppf "@,Internal operations: %d" (List.length ops)
+              end ;
+              begin match originated_contracts with
+                | [] -> ()
+                | contracts ->
+                    Format.fprintf ppf "@,@[<v 2>Originated contracts:@,%a@]"
+                      (Format.pp_print_list Contract.pp) contracts
+              end ;
+              begin match storage with
+                | None -> ()
+                | Some expr ->
+                    Format.fprintf ppf "@,@[<hv 2>Updated storage:@ %a@]"
+                      Michelson_v1_printer.print_expr expr
+              end ;
+              begin if storage_fees_increment <> Tez.zero then
+                  Format.fprintf ppf
+                    "@,Storage fees increment: %s%a"
+                    Client_proto_args.tez_sym
+                    Tez.pp storage_fees_increment
+              end ;
+              Format.fprintf ppf
+                "@,Consumed gas: %s"
+                (Z.to_string consumed_gas) ;
+              begin match balance_updates with
+                | [] -> ()
+                | balance_updates ->
+                    Format.fprintf ppf
+                      "@,Balance updates:@,  %a"
+                      pp_balance_updates balance_updates
+              end
+          | Applied (Origination_result { balance_updates ; consumed_gas ;
+                                          originated_contracts ; storage_fees_increment }) ->
+              Format.fprintf ppf
+                "This transaction was successfully applied:" ;
+              begin match originated_contracts with
+                | [] -> ()
+                | contracts ->
+                    Format.fprintf ppf "@,@[<v 2>Originated contracts:@,%a@]"
+                      (Format.pp_print_list Contract.pp) contracts
+              end ;
+              begin if storage_fees_increment <> Tez.zero then
+                  Format.fprintf ppf
+                    "@,Storage fees increment: %s%a"
+                    Client_proto_args.tez_sym
+                    Tez.pp storage_fees_increment
+              end ;
+              Format.fprintf ppf
+                "@,Consumed gas: %s"
+                (Z.to_string consumed_gas) ;
+              begin match balance_updates with
+                | [] -> ()
+                | balance_updates ->
+                    Format.fprintf ppf
+                      "@,Balance updates:@,  %a"
+                      pp_balance_updates balance_updates
+              end in
+        let rec pp_manager_operations_results ppf = function
+          | [], [] -> ()
+          | operation :: ops, (External, r) :: rs ->
+              Format.fprintf ppf "@," ;
+              pp_manager_operation_content ppf source operation false pp_result r ;
+              pp_manager_operations_results ppf (ops, rs)
+          | ops, (Internal { source ; operation }, r) :: rs ->
+              Format.fprintf ppf "@," ;
+              pp_manager_operation_content ppf source operation true pp_result r ;
+              pp_manager_operations_results ppf (ops, rs)
+          | [], _ :: _
+          | _ :: _, [] -> invalid_arg "Apply_operation_result.pp" in
+        Format.fprintf ppf
+          "@[<v 0>@[<v 2>Manager signed operations:@,\
+           From: %a@,\
+           Fee to the baker: %s%a@,\
+           Expected counter: %ld@,\
+           Gas limit: %s"
+          Contract.pp source
+          Client_proto_args.tez_sym
+          Tez.pp fee
+          counter
+          (Z.to_string gas_limit) ;
+        begin match balance_updates with
+          | [] -> ()
+          | balance_updates ->
+              Format.fprintf ppf
+                "@,Balance updates:@,  %a"
+                pp_balance_updates balance_updates
+        end ;
+        Format.fprintf ppf
+          "@]%a@]"
+          pp_manager_operations_results (operations, operation_results)
+    | _, _ -> invalid_arg "Apply_operation_result.pp"
+  end ;
+  Format.fprintf ppf "@]"
+
+let pp_internal_operation ppf { source ; operation } =
+  pp_manager_operation_content ppf source operation true (fun _ppf () -> ()) ()
+
+let estimated_gas = function
+  | Sourced_operation_result (Manager_operations_result { operation_results }) ->
+      List.fold_left
+        (fun acc (_, r) -> acc >>? fun acc ->
+          match r with
+          | Applied (Transaction_result { consumed_gas }
+                    | Origination_result { consumed_gas }) ->
+              Ok (Z.add consumed_gas acc)
+          | Applied Reveal_result -> Ok acc
+          | Applied Delegation_result -> Ok acc
+          | Skipped -> assert false
+          | Failed errs -> Alpha_environment.wrap_error (Error errs))
+        (Ok Z.zero) operation_results
+  | _ -> Ok Z.zero
+
+let originated_contracts = function
+  | Sourced_operation_result (Manager_operations_result { operation_results }) ->
+      List.fold_left
+        (fun acc (_, r) -> acc >>? fun acc ->
+          match r with
+          | Applied (Transaction_result { originated_contracts }
+                    | Origination_result { originated_contracts }) ->
+              Ok (originated_contracts @ acc)
+          | Applied Reveal_result -> Ok acc
+          | Applied Delegation_result -> Ok acc
+          | Skipped -> assert false
+          | Failed errs -> Alpha_environment.wrap_error (Error errs))
+        (Ok []) operation_results
+  | _ -> Ok []
+
 let transfer (cctxt : #Proto_alpha.full)
     block ?branch
     ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee ?gas_limit () =
@@ -130,18 +433,14 @@ let transfer (cctxt : #Proto_alpha.full)
         let signed_bytes = Signature.concat bytes signature in
         let oph = Operation_hash.hash_bytes [ signed_bytes ] in
         Alpha_services.Helpers.apply_operation cctxt block
-          predecessor oph bytes (Some signature) >>=? fun (_, _, gas) ->
+          predecessor oph bytes (Some signature) >>=? fun result ->
-        match gas with
+        Lwt.return (estimated_gas result) >>=? fun gas ->
-        | Limited { remaining } ->
-            let gas = Z.sub max_gas remaining in
         if Z.equal gas Z.zero then
           cctxt#message "Estimated gas: none" >>= fun () ->
           return Z.zero
         else
-              let gas = Z.sub max_gas remaining in
           cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
           return (Z.add gas (Z.of_int 100))
-        | Unaccounted -> assert false
   end >>=? fun gas_limit ->
   Alpha_services.Forge.Manager.transaction
     cctxt block
@@ -152,12 +451,14 @@ let transfer (cctxt : #Proto_alpha.full)
   let signed_bytes = Signature.concat bytes signature in
   let oph = Operation_hash.hash_bytes [ signed_bytes ] in
   Alpha_services.Helpers.apply_operation cctxt block
-    predecessor oph bytes (Some signature) >>=? fun (contracts, operations, _) ->
+    predecessor oph bytes (Some signature) >>=? fun result ->
-  cctxt#message "@[<v 2>This sequence of operations was run (including internal ones):@,%a@]"
+  cctxt#message
-    (Format.pp_print_list pp_internal_operation) operations >>= fun () ->
+    "@[<v 2>This sequence of operations was run:@,%a@]"
+    pp_operation_result (Data_encoding.Binary.of_bytes_exn Operation.encoding signed_bytes, result) >>= fun () ->
   Shell_services.inject_operation
     cctxt ~chain_id signed_bytes >>=? fun injected_oph ->
   assert (Operation_hash.equal oph injected_oph) ;
+  Lwt.return (originated_contracts result) >>=? fun contracts ->
   return (oph, contracts)
 
 let reveal cctxt
@@ -185,16 +486,17 @@ let originate (cctxt : #Client_context.full) ?chain_id ~block ?signature bytes =
   Block_services.predecessor cctxt block >>=? fun predecessor ->
   let oph = Operation_hash.hash_bytes [ signed_bytes ] in
   Alpha_services.Helpers.apply_operation cctxt block
-    predecessor oph bytes signature >>=? function
+    predecessor oph bytes signature >>=? fun result ->
-  | [ contract ], operations, _ ->
+  Lwt.return (originated_contracts result) >>=? function
+  | [ contract ] ->
       cctxt#message
-        "@[<v 2>This sequence of operations was run (including internal ones):@,%a@]"
+        "@[<v 2>This sequence of operations was run:@,%a@]"
-        (Format.pp_print_list pp_internal_operation) operations >>= fun () ->
+        pp_operation_result (Data_encoding.Binary.of_bytes_exn Operation.encoding signed_bytes, result) >>= fun () ->
       Shell_services.inject_operation
         cctxt ?chain_id signed_bytes >>=? fun injected_oph ->
       assert (Operation_hash.equal oph injected_oph) ;
       return (oph, contract)
-  | contracts, _, _ ->
+  | contracts ->
       failwith
         "The origination introduced %d contracts instead of one."
         (List.length contracts)
@@ -205,7 +507,7 @@ let operation_submitted_message (cctxt : #Client_context.printer) ?(contracts =
   Lwt_list.iter_s
     (fun c ->
        cctxt#message
-         "New contract %a originated from a smart contract."
+         "New contract %a originated."
          Contract.pp c)
     contracts >>= return
 
@@ -349,17 +651,14 @@ let originate_contract
         let signed_bytes = Signature.concat bytes signature in
         let oph = Operation_hash.hash_bytes [ signed_bytes ] in
         Alpha_services.Helpers.apply_operation cctxt block
-          predecessor oph bytes (Some signature) >>=? fun (_, _, gas) ->
+          predecessor oph bytes (Some signature) >>=? fun result ->
-        match gas with
+        Lwt.return (estimated_gas result) >>=? fun gas ->
-        | Limited { remaining } ->
-            let gas = Z.sub max_gas remaining in
         if Z.equal gas Z.zero then
           cctxt#message "Estimated gas: none" >>= fun () ->
           return Z.zero
         else
           cctxt#message "Estimated gas: %s units (will add 100 for safety)" (Z.to_string gas) >>= fun () ->
           return (Z.add gas (Z.of_int 100))
-        | Unaccounted -> assert false
   end >>=? fun gas_limit ->
   Alpha_services.Forge.Manager.origination cctxt block
     ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager

src/proto_alpha/lib_client/client_proto_context.mli

@@ -59,6 +59,9 @@ val operation_submitted_message :
 val pp_internal_operation:
   Format.formatter -> internal_operation -> unit
 
+val pp_operation_result :
+  Format.formatter -> (operation * Apply_operation_result.operation_result) -> unit
+
 val source_to_keys:
   #Proto_alpha.full ->
   Block_services.block ->

src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL

@@ -64,6 +64,7 @@
 
         "Baking",
         "Amendment",
+        "Apply_operation_result",
         "Apply",
 
         "Services_registration",

src/proto_alpha/lib_protocol/src/apply.ml

@@ -327,6 +327,8 @@ let () =
     (function Multiple_revelation -> Some () | _ -> None)
     (fun () -> Multiple_revelation)
 
+open Apply_operation_result
+
 let apply_consensus_operation_content ctxt
     pred_block block_priority operation = function
   | Endorsements { block ; level ; slots } ->
@@ -354,7 +356,7 @@ let apply_consensus_operation_content ctxt
       Baking.freeze_endorsement_deposit ctxt delegate >>=? fun ctxt ->
       Baking.endorsement_reward ctxt ~block_priority >>=? fun reward ->
       Delegate.freeze_rewards ctxt delegate reward >>=? fun ctxt ->
-      return ctxt
+      return (ctxt, Endorsements_result (delegate, slots))
 
 let apply_amendment_operation_content ctxt delegate = function
   | Proposals { period ; proposals } ->
@@ -368,57 +370,94 @@ let apply_amendment_operation_content ctxt delegate = function
         (Wrong_voting_period (level.voting_period, period)) >>=? fun () ->
       Amendment.record_ballot ctxt delegate proposal ballot
 
-let apply_manager_operation_content
+let gas_difference ctxt_before ctxt_after =
-    ctxt ~payer ~source ~internal = function
+  match Gas.level ctxt_before, Gas.level ctxt_after with
-  | Reveal _ -> return (ctxt, None, Tez.zero, [])
+  | Limited { remaining = before }, Limited { remaining = after } -> Z.sub before after
-  | Transaction { amount ; parameters ; destination } ->
+  | _ -> Z.zero
-      begin
+
-        begin
+let new_contracts ctxt_before ctxt_after =
+  Contract.originated_from_current_nonce ctxt_before >>=? fun before ->
+  Contract.originated_from_current_nonce ctxt_after >>=? fun after ->
+  return (List.filter (fun c -> not (List.exists (Contract.equal c) before)) after)
+
+let cleanup_balance_updates balance_updates =
+  List.filter
+    (fun (_, (Credited update | Debited update)) ->
+       not (Tez.equal update Tez.zero))
+    balance_updates
+
+let apply_manager_operation_content ctxt ~payer ~source ~internal operation =
+  let before_operation = ctxt in
+  Contract.must_exist ctxt source >>=? fun () ->
+  match operation with
+  | Reveal _ -> return (ctxt, Reveal_result)
+  | Transaction { amount ; parameters ; destination } -> begin
+      let spend =
         if internal then
-            Contract.spend_from_script ctxt source amount
+          Contract.spend_from_script
         else
-            Contract.spend ctxt source amount
+          Contract.spend in
-        end >>=? fun ctxt ->
+      spend ctxt source amount >>=? fun ctxt ->
       Contract.credit ctxt destination amount >>=? fun ctxt ->
       Contract.get_script ctxt destination >>=? fun (ctxt, script) -> match script with
       | None -> begin
           match parameters with
-            | None ->
+          | None -> return ()
-                return (ctxt, None, Tez.zero, [])
           | Some arg ->
               match Micheline.root arg with
               | Prim (_, D_Unit, [], _) ->
-                    return (ctxt, None, Tez.zero, [])
+                  return ()
               | _ -> fail (Bad_contract_parameter (destination, None, parameters))
-          end
+        end >>=? fun () ->
+          let result =
+            Transaction_result
+              { operations = [] ;
+                storage = None ;
+                balance_updates =
+                  cleanup_balance_updates
+                    [ Contract source, Debited amount ;
+                      Contract destination, Credited amount ] ;
+                originated_contracts = [] ;
+                consumed_gas = gas_difference before_operation ctxt ;
+                storage_fees_increment = Tez.zero } in
+          return (ctxt, result)
       | Some script ->
-            let call_contract ctxt parameter =
+          Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
+          let arg_type = Micheline.strip_locations arg_type in
+          begin match parameters, Micheline.root arg_type with
+            | None, Prim (_, T_unit, _, _) ->
+                return (ctxt, (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None))))
+            | Some parameters, _ ->
+                trace
+                  (Bad_contract_parameter (destination, Some arg_type, Some parameters))
+                  (Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type)) >>=? fun ctxt ->
+                return (ctxt, parameters)
+            | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
+          end >>=? fun (ctxt, parameter) ->
           Script_interpreter.execute
             ctxt
             ~check_operations:(not internal)
             ~source ~payer ~self:(destination, script) ~amount ~parameter
-              >>= function
+          >>=? fun { ctxt ; storage ; big_map_diff ; operations } ->
-              | Ok { ctxt ; storage ; big_map_diff ; operations } ->
           Contract.update_script_storage
             ctxt destination storage big_map_diff >>=? fun ctxt ->
           Fees.update_script_storage
             ctxt ~payer destination >>=? fun (ctxt, fees) ->
-                  return (ctxt, None, fees, operations)
+          new_contracts before_operation ctxt >>=? fun originated_contracts ->
-              | Error err ->
+          let result =
-                  return (ctxt, Some err, Tez.zero, []) in
+            Transaction_result
-            Lwt.return @@ Script_ir_translator.parse_toplevel script.code >>=? fun (arg_type, _, _) ->
+              { operations ;
-            let arg_type = Micheline.strip_locations arg_type in
+                storage = Some storage ;
-            match parameters, Micheline.root arg_type with
+                balance_updates =
-            | None, Prim (_, T_unit, _, _) ->
+                  cleanup_balance_updates
-                call_contract ctxt (Micheline.strip_locations (Prim (0, Script.D_Unit, [], None)))
+                    [ Contract payer, Debited fees ;
-            | Some parameters, _ -> begin
+                      Contract source, Debited amount ;
-                Script_ir_translator.typecheck_data ctxt ~check_operations:true (parameters, arg_type) >>= function
+                      Contract destination, Credited amount ;
-                | Ok ctxt -> call_contract ctxt parameters
+                      (* FIXME: this is wrong until we have asynchronous orignations *) ] ;
-                | Error errs ->
+                originated_contracts ;
-                    let err = Bad_contract_parameter (destination, Some arg_type, Some parameters) in
+                consumed_gas = gas_difference before_operation ctxt ;
-                    return (ctxt, Some ((err :: errs)), Tez.zero, [])
+                storage_fees_increment = fees } in
-              end
+          return (ctxt, result)
-            | None, _ -> fail (Bad_contract_parameter (destination, Some arg_type, None))
     end
   | Origination { manager ; delegate ; script ;
                   spendable ; delegatable ; credit } ->
@@ -434,55 +473,70 @@ let apply_manager_operation_content
         ~manager ~delegate ~balance:credit
         ?script
         ~spendable ~delegatable >>=? fun (ctxt, contract) ->
-      Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
+      Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, fees) ->
-      return (ctxt, None, Tez.zero, [])
+      let result =
+        Origination_result
+          { balance_updates =
+              cleanup_balance_updates
+                [ Contract payer, Debited fees ;
+                  Contract source, Debited credit ;
+                  Contract contract, Credited credit ] ;
+            originated_contracts = [ contract ] ;
+            consumed_gas = gas_difference before_operation ctxt ;
+            storage_fees_increment = fees } in
+      return (ctxt, result)
   | Delegation delegate ->
       Delegate.set ctxt source delegate >>=? fun ctxt ->
-      return (ctxt, None, Tez.zero, [])
+      return (ctxt, Delegation_result)
 
 let apply_internal_manager_operations ctxt ~payer ops =
-  let rec apply ctxt storage_fees applied worklist =
+  let rec apply ctxt applied worklist =
     match worklist with
-    | [] -> return (ctxt, None, storage_fees, List.rev applied)
+    | [] -> Lwt.return (Ok (ctxt, applied))
     | { source ; operation ;
         signature = _ (* at this point the signature must have been
                          checked if the operation has been
                          deserialized from the outside world *) } as op :: rest ->
-        apply_manager_operation_content ctxt ~source ~payer ~internal:true operation
+        apply_manager_operation_content ctxt ~source ~payer ~internal:true operation >>= function
-        >>=? fun (ctxt, ignored_error, operation_storage_fees, emitted) ->
+        | Error errors ->
-        Lwt.return Tez.(storage_fees +? operation_storage_fees) >>=? fun storage_fees ->
+            let result = Internal op, Failed errors in
-        match ignored_error with
+            let skipped = List.rev_map (fun op -> Internal op, Skipped) rest in
-        | Some err ->
+            Lwt.return (Error (skipped @ (result :: applied)))
-            return (ctxt, Some err, storage_fees, List.rev (op :: applied))
+        | Ok (ctxt, (Transaction_result { operations = emitted ; _ } as result)) ->
-        | None ->
+            apply ctxt ((Internal op, Applied result) :: applied) (rest @ emitted)
-            apply ctxt storage_fees (op :: applied) (rest @ emitted) in
+        | Ok (ctxt, result) ->
-  apply ctxt Tez.zero [] ops
+            apply ctxt ((Internal op, Applied result) :: applied) rest in
+  apply ctxt [] ops
 
 let apply_manager_operations ctxt source ops =
-  let rec apply ctxt storage_fees applied ops =
+  let rec apply ctxt applied ops =
     match ops with
-    | [] -> return (ctxt, None, storage_fees, List.rev applied)
+    | [] -> Lwt.return (Ok (ctxt, List.rev applied))
     | operation :: rest ->
-        Contract.must_exist ctxt source >>=? fun () ->
         apply_manager_operation_content ctxt ~source ~payer:source ~internal:false operation
-        >>=? fun (ctxt, ignored_error, operation_storage_fees, emitted) ->
+        >>= function
-        Lwt.return Tez.(storage_fees +? operation_storage_fees) >>=? fun storage_fees ->
+        | Error errors ->
-        let op = { source ; operation ; signature = None } in
+            let result = External, Failed errors in
-        match ignored_error with
+            let skipped = List.rev_map (fun _ -> External, Skipped) rest in
-        | Some _ -> return (ctxt, ignored_error, storage_fees, List.rev (op :: applied))
+            Lwt.return (Error (List.rev (skipped @ (result :: applied))))
-        | None ->
+        | Ok (ctxt, result) ->
+            let emitted =
+              match result with
+              | Transaction_result { operations = emitted ; _ } -> emitted
+              | _ -> [] in
             apply_internal_manager_operations ctxt ~payer:source emitted
-            >>=? fun (ctxt, ignored_error, internal_storage_fees, internal_applied) ->
+            >>= function
-            let applied = List.rev internal_applied @ (op :: applied) in
+            | Error (results) ->
-            Lwt.return Tez.(storage_fees +? internal_storage_fees) >>=? fun storage_fees ->
+                let result = (External, Applied result) in
-            match ignored_error with
+                let skipped = List.map (fun _ -> External, Skipped) rest in
-            | Some _ -> return (ctxt, ignored_error, storage_fees, List.rev applied)
+                Lwt.return (Error (List.rev (skipped @ results @ (result :: applied))))
-            | None -> apply ctxt storage_fees applied rest in
+            | Ok (ctxt, results) ->
-  apply ctxt Tez.zero [] ops
+                let result = (External, Applied result) in
+                let applied = results @ (result :: applied) in
+                apply ctxt applied rest in
+  apply ctxt [] ops
 
-let apply_sourced_operation
+let apply_sourced_operation ctxt pred_block block_prio operation ops =
-    ctxt pred_block block_prio
-    operation ops =
   match ops with
   | Manager_operations { source ; fee ; counter ; operations ; gas_limit } ->
       let revealed_public_keys =
@@ -506,32 +560,40 @@ let apply_sourced_operation
       Contract.spend ctxt source fee >>=? fun ctxt ->
       add_fees ctxt fee >>=? fun ctxt ->
       Lwt.return (Gas.set_limit ctxt gas_limit) >>=? fun ctxt ->
-      apply_manager_operations ctxt source operations
+      apply_manager_operations ctxt source operations >>= begin function
-      >>=? fun (ctxt, ignored_error, storage_fees, applied) ->
+        | Ok (ctxt, operation_results) -> return (ctxt, operation_results)
-      return (ctxt, ignored_error, storage_fees, applied)
+        | Error operation_results -> return (ctxt (* backtracked *), operation_results)
+      end >>=? fun (ctxt, operation_results) ->
+      return (ctxt,
+              Manager_operations_result
+                { balance_updates =
+                    cleanup_balance_updates
+                      [ Contract source, Debited fee ;
+                        (* FIXME: add credit to the baker *) ] ;
+                  operation_results })
   | Consensus_operation content ->
       apply_consensus_operation_content ctxt
-        pred_block block_prio operation content >>=? fun ctxt ->
+        pred_block block_prio operation content >>=? fun (ctxt, result) ->
-      return (ctxt, None, Tez.zero, [])
+      return (ctxt, Consensus_operation_result result)
   | Amendment_operation { source ; operation = content } ->
       Roll.delegate_pubkey ctxt source >>=? fun delegate ->
       Operation.check_signature delegate operation >>=? fun () ->
       (* TODO, see how to extract the public key hash after this operation to
          pass it to apply_delegate_operation_content *)
       apply_amendment_operation_content ctxt source content >>=? fun ctxt ->
-      return (ctxt, None, Tez.zero, [])
+      return (ctxt, Amendment_operation_result)
   | Dictator_operation (Activate hash) ->
       let dictator_pubkey = Constants.dictator_pubkey ctxt in
       Operation.check_signature dictator_pubkey operation >>=? fun () ->
       activate ctxt hash >>= fun ctxt ->
-      return (ctxt, None, Tez.zero, [])
+      return (ctxt, Dictator_operation_result)
   | Dictator_operation (Activate_testchain hash) ->
       let dictator_pubkey = Constants.dictator_pubkey ctxt in
       Operation.check_signature dictator_pubkey operation >>=? fun () ->
       let expiration = (* in two days maximum... *)
         Time.add (Timestamp.current ctxt) (Int64.mul 48L 3600L) in
       fork_test_chain ctxt hash expiration >>= fun ctxt ->
-      return (ctxt, None, Tez.zero, [])
+      return (ctxt, Dictator_operation_result)
 
 let apply_anonymous_operation ctxt _delegate kind =
   match kind with
@@ -541,7 +603,7 @@ let apply_anonymous_operation ctxt _delegate kind =
       let seed_nonce_revelation_tip =
         Constants.seed_nonce_revelation_tip ctxt in
       add_rewards ctxt seed_nonce_revelation_tip >>=? fun ctxt ->
-      return ctxt
+      return (ctxt, Seed_nonce_revelation_result [(* FIXME *)])
   | Double_endorsement_evidence { op1 ; op2 } -> begin
       match op1.contents, op2.contents with
       | Sourced_operations (Consensus_operation (Endorsements e1)),
@@ -580,7 +642,7 @@ let apply_anonymous_operation ctxt _delegate kind =
             | Ok v -> v
             | Error _ -> Tez.zero in
           add_rewards ctxt reward >>=? fun ctxt ->
-          return ctxt
+          return (ctxt, Double_endorsement_evidence_result [(* FIXME *)])
       | _, _ -> fail Invalid_double_endorsement_evidence
     end
   | Double_baking_evidence { bh1 ; bh2 } ->
@@ -619,7 +681,7 @@ let apply_anonymous_operation ctxt _delegate kind =
         | Ok v -> v
         | Error _ -> Tez.zero in
       add_rewards ctxt reward >>=? fun ctxt ->
-      return ctxt
+      return (ctxt, Double_baking_evidence_result [(* FIXME *)])
   | Activation { id = pkh ; secret } ->
       let h_pkh = Unclaimed_public_key_hash.of_ed25519_pkh pkh in
       Commitment.get_opt ctxt h_pkh >>=? function
@@ -631,17 +693,7 @@ let apply_anonymous_operation ctxt _delegate kind =
             Wrong_activation_secret >>=? fun () ->
           Commitment.delete ctxt h_pkh >>=? fun ctxt ->
           Contract.(credit ctxt (implicit_contract (Signature.Ed25519 pkh)) amount) >>=? fun ctxt ->
-          return ctxt
+          return (ctxt, Activation_result [(* FIXME *)])
-
-type operation_result =
-  { ctxt : context ;
-    gas : Gas.t ;
-    contracts : Contract.t list ;
-    ignored_error : error list option ;
-    internal_operations : internal_operation list ;
-    fees : Tez.t ;
-    rewards : Tez.t ;
-    storage_fees : Tez.t }
 
 let apply_operation
     ctxt delegate pred_block block_prio hash operation =
@@ -649,24 +701,20 @@ let apply_operation
   begin match operation.contents with
     | Anonymous_operations ops ->
         fold_left_s
-          (fun ctxt op ->
+          (fun (ctxt, acc) op ->
-             apply_anonymous_operation ctxt delegate op)
+             apply_anonymous_operation ctxt delegate op >>=? fun (ctxt, result) ->
-          ctxt ops
+             return (ctxt, result :: acc))
-        >>=? fun ctxt ->
+          (ctxt, []) ops
-        return (ctxt, None, Tez.zero, [])
+        >>=? fun (ctxt, results) ->
-    | Sourced_operations op ->
+        return (ctxt, Anonymous_operations_result (List.rev results))
-        apply_sourced_operation
+    | Sourced_operations ops ->
-          ctxt pred_block block_prio
+        apply_sourced_operation ctxt pred_block block_prio operation ops
-          operation op
+        >>=? fun (ctxt, result) ->
-  end >>=? fun (ctxt, ignored_error, storage_fees, internal_operations) ->
+        return (ctxt, Sourced_operation_result result)
-  let gas = Gas.level ctxt in
+  end >>=? fun (ctxt, result) ->
   let ctxt = Gas.set_unlimited ctxt in
-  Contract.originated_from_current_nonce ctxt >>=? fun contracts ->
   let ctxt = Contract.unset_origination_nonce ctxt in
-  return { ctxt ; gas ; ignored_error ; storage_fees ;
+  return (ctxt, result)
-           internal_operations ; contracts ;
-           fees = Alpha_context.get_fees ctxt ;
-           rewards = Alpha_context.get_rewards ctxt }
 
 let may_snapshot_roll ctxt =
   let level = Alpha_context.Level.current ctxt in

src/proto_alpha/lib_protocol/src/apply_operation_result.ml

@@ -0,0 +1,277 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Alpha_context
+open Data_encoding
+
+type balance =
+  | Contract of Contract.t
+  | Rewards of Signature.Public_key_hash.t * Cycle.t
+  | Fees of Signature.Public_key_hash.t * Cycle.t
+  | Deposits of Signature.Public_key_hash.t * Cycle.t
+
+let balance_encoding =
+  union
+    [ case Json_only
+        (obj2
+           (req "kind" (constant "contract"))
+           (req "contract" Contract.encoding))
+        (function Contract c -> Some ((), c) | _ -> None )
+        (fun ((), c) -> (Contract c)) ;
+      case Json_only
+        (obj4
+           (req "kind" (constant "freezer"))
+           (req "category" (constant "rewards"))
+           (req "delegate" Signature.Public_key_hash.encoding)
+           (req "level" Cycle.encoding))
+        (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
+        (fun ((), (), d, l) -> Rewards (d, l)) ;
+      case Json_only
+        (obj4
+           (req "kind" (constant "freezer"))
+           (req "category" (constant "fees"))
+           (req "delegate" Signature.Public_key_hash.encoding)
+           (req "level" Cycle.encoding))
+        (function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
+        (fun ((), (), d, l) -> Fees (d, l)) ;
+      case Json_only
+        (obj4
+           (req "kind" (constant "freezer"))
+           (req "category" (constant "deposits"))
+           (req "delegate" Signature.Public_key_hash.encoding)
+           (req "level" Cycle.encoding))
+        (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
+        (fun ((), (), d, l) -> Deposits (d, l)) ]
+
+type balance_update =
+  | Debited of Tez.t
+  | Credited of Tez.t
+
+let balance_update_encoding =
+  union
+    [ case Json_only
+        (obj1 (req "credited" Tez.encoding))
+        (function Credited v -> Some v | Debited _ -> None)
+        (fun v -> Credited v) ;
+      case Json_only
+        (obj1 (req "debited" Tez.encoding))
+        (function Debited v -> Some v | Credited _ -> None)
+        (fun v -> Debited v) ]
+
+type balance_updates = (balance * balance_update) list
+
+let balance_updates_encoding =
+  list (merge_objs balance_encoding balance_update_encoding)
+
+type anonymous_operation_result =
+  | Seed_nonce_revelation_result of balance_updates
+  | Double_endorsement_evidence_result of balance_updates
+  | Double_baking_evidence_result of balance_updates
+  | Activation_result of balance_updates
+
+let anonymous_operation_result_encoding =
+  union
+    [ case Json_only
+        (obj2
+           (req "kind" (constant "revelation"))
+           (req "balance_updates" balance_updates_encoding))
+        (function Seed_nonce_revelation_result bus -> Some ((), bus) | _ -> None)
+        (fun ((), bus) -> Seed_nonce_revelation_result bus) ;
+      case Json_only
+        (obj2
+           (req "kind" (constant "double_endorsement"))
+           (req "balance_updates" balance_updates_encoding))
+        (function Double_endorsement_evidence_result bus -> Some ((), bus) | _ -> None)
+        (fun ((), bus) -> Double_endorsement_evidence_result bus) ;
+      case Json_only
+        (obj2
+           (req "kind" (constant "double_baking"))
+           (req "balance_updates" balance_updates_encoding))
+        (function Double_baking_evidence_result bus -> Some ((), bus) | _ -> None)
+        (fun ((), bus) -> Double_baking_evidence_result bus) ;
+      case Json_only
+        (obj2
+           (req "kind" (constant "activation"))
+           (req "balance_updates" balance_updates_encoding))
+        (function Activation_result bus -> Some ((), bus) | _ -> None)
+        (fun ((), bus) -> Activation_result bus) ]
+
+type successful_manager_operation_result =
+  | Reveal_result
+  | Transaction_result of
+      { operations : internal_operation list ;
+        storage : Script.expr option ;
+        balance_updates : balance_updates ;
+        originated_contracts : Contract.t list ;
+        consumed_gas : Z.t ;
+        storage_fees_increment : Tez.t }
+  | Origination_result of
+      { balance_updates : balance_updates ;
+        originated_contracts : Contract.t list ;
+        consumed_gas : Z.t ;
+        storage_fees_increment : Tez.t }
+  | Delegation_result
+
+type manager_operation_kind =
+  | External
+  | Internal of internal_operation
+
+let manager_operation_kind_encoding =
+  union
+    [ case Json_only (constant "external")
+        (function External -> Some () | _ -> None)
+        (fun () -> External) ;
+      case Json_only Operation.internal_operation_encoding
+        (function Internal op -> Some op | _ -> None)
+        (fun op -> Internal op) ]
+
+type manager_operation_result =
+  | Applied of successful_manager_operation_result
+  | Failed of error list
+  | Skipped
+
+let manager_operation_result_encoding =
+  union
+    [ case Json_only
+        (obj2
+           (req "status" (constant "applied"))
+           (req "operation_kind" (constant "reveal")))
+        (function Applied Reveal_result -> Some ((),()) | _ -> None)
+        (fun ((),()) -> Applied Reveal_result) ;
+      case Json_only
+        (obj8
+           (req "status" (constant "applied"))
+           (req "operation_kind" (constant "transaction"))
+           (dft "emitted" (list Operation.internal_operation_encoding) [])
+           (opt "storage" Script.expr_encoding)
+           (dft "balance_updates" balance_updates_encoding [])
+           (dft "originated_contracts" (list Contract.encoding) [])
+           (dft "consumed_gas" z Z.zero)
+           (dft "storage_fees_increment" Tez.encoding Tez.zero))
+        (function
+          | Applied (Transaction_result
+                       { operations ; storage ; balance_updates ;
+                         originated_contracts ; consumed_gas ;
+                         storage_fees_increment }) ->
+              Some ((), (), operations, storage, balance_updates,
+                    originated_contracts, consumed_gas,
+                    storage_fees_increment)
+          | _ -> None)
+        (fun ((), (), operations, storage, balance_updates,
+              originated_contracts, consumed_gas,
+              storage_fees_increment) ->
+          Applied (Transaction_result
+                     { operations ; storage ; balance_updates ;
+                       originated_contracts ; consumed_gas ;
+                       storage_fees_increment })) ;
+      case Json_only
+        (obj6
+           (req "status" (constant "applied"))
+           (req "operation_kind" (constant "origination"))
+           (dft "balance_updates" balance_updates_encoding [])
+           (dft "originated_contracts" (list Contract.encoding) [])
+           (dft "consumed_gas" z Z.zero)
+           (dft "storage_fees_increment" Tez.encoding Tez.zero))
+        (function
+          | Applied (Origination_result
+                       { balance_updates ;
+                         originated_contracts ; consumed_gas ;
+                         storage_fees_increment }) ->
+              Some ((), (), balance_updates,
+                    originated_contracts, consumed_gas,
+                    storage_fees_increment)
+          | _ -> None)
+        (fun ((), (), balance_updates,
+              originated_contracts, consumed_gas,
+              storage_fees_increment) ->
+          Applied (Origination_result
+                     { balance_updates ;
+                       originated_contracts ; consumed_gas ;
+                       storage_fees_increment })) ;
+      case Json_only
+        (obj2
+           (req "status" (constant "applied"))
+           (req "operation_kind" (constant "delegation")))
+        (function Applied Delegation_result -> Some ((),()) | _ -> None)
+        (fun ((),()) -> Applied Delegation_result) ;
+      case Json_only
+        (obj2
+           (req "status" (constant "failed"))
+           (req "errors" (list Error_monad.error_encoding)))
+        (function Failed errs -> Some ((), errs) | _ -> None)
+        (fun ((), errs) -> Failed errs) ;
+      case Json_only
+        (obj1 (req "status" (constant "skipped")))
+        (function Skipped -> Some () | _ -> None)
+        (fun () -> Skipped) ]
+
+type consensus_operation_result =
+  | Endorsements_result of Signature.Public_key_hash.t * int list
+
+type sourced_operation_result =
+  | Consensus_operation_result of consensus_operation_result
+  | Amendment_operation_result
+  | Manager_operations_result of
+      { balance_updates : balance_updates ;
+        operation_results : (manager_operation_kind * manager_operation_result) list }
+  | Dictator_operation_result
+
+type operation_result =
+  | Anonymous_operations_result of anonymous_operation_result list
+  | Sourced_operation_result of sourced_operation_result
+
+let encoding =
+  union
+    [ case Json_only
+        (obj2
+           (req "kind" (constant "anonymous"))
+           (req "results" (list anonymous_operation_result_encoding)))
+        (function Anonymous_operations_result rs -> Some ((), rs) | _ -> None)
+        (fun ((), rs) -> Anonymous_operations_result rs) ;
+      case Json_only
+        (obj3
+           (req "kind" (constant "endorsements"))
+           (req "delegate" Signature.Public_key_hash.encoding)
+           (req "slots" (list uint8)))
+        (function
+          | Sourced_operation_result
+              (Consensus_operation_result
+                 (Endorsements_result (d, s))) -> Some ((), d, s)
+          | _ -> None)
+        (fun ((), d, s) ->
+           Sourced_operation_result
+             (Consensus_operation_result
+                (Endorsements_result (d, s)))) ;
+      case Json_only
+        (obj1
+           (req "kind" (constant "amendment")))
+        (function Sourced_operation_result Amendment_operation_result -> Some () | _ -> None)
+        (fun () -> Sourced_operation_result Amendment_operation_result) ;
+      case Json_only
+        (obj1
+           (req "kind" (constant "dictator")))
+        (function Sourced_operation_result Dictator_operation_result -> Some () | _ -> None)
+        (fun () -> Sourced_operation_result Dictator_operation_result) ;
+      case Json_only
+        (obj3
+           (req "kind" (constant "manager"))
+           (req "balance_updates" balance_updates_encoding)
+           (req "operation_results"
+              (list (merge_objs
+                       (obj1 (req "operation" manager_operation_kind_encoding))
+                       manager_operation_result_encoding))))
+        (function
+          | Sourced_operation_result
+              (Manager_operations_result
+                 { balance_updates = bus ; operation_results = rs }) ->
+              Some ((), bus, rs) | _ -> None)
+        (fun ((), bus, rs) ->
+           Sourced_operation_result
+             (Manager_operations_result
+                { balance_updates = bus ; operation_results = rs })) ]

src/proto_alpha/lib_protocol/src/apply_operation_result.mli

@@ -0,0 +1,95 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2018.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Result of applying an operation, can be used for experimenting
+    with protocol updates, by clients to print out a summary of the
+    operation at pre-injection simulation and at confirmation time,
+    and by block explorers. *)
+
+open Alpha_context
+
+(** Places where tezzies can be found in the ledger's state. *)
+type balance =
+  | Contract of Contract.t
+  | Rewards of Signature.Public_key_hash.t * Cycle.t
+  | Fees of Signature.Public_key_hash.t * Cycle.t
+  | Deposits of Signature.Public_key_hash.t * Cycle.t
+
+(** A credit or debit of tezzies to a balance. *)
+type balance_update =
+  | Debited of Tez.t
+  | Credited of Tez.t
+
+(** A list of balance updates. Duplicates may happen. *)
+type balance_updates = (balance * balance_update) list
+
+(** Result of applying a {!proto_operation}. Follows the same structure. *)
+type operation_result =
+  | Anonymous_operations_result of anonymous_operation_result list
+  | Sourced_operation_result of sourced_operation_result
+
+(** Result of applying an {!anonymous_operation}. Follows the same structure. *)
+and anonymous_operation_result =
+  | Seed_nonce_revelation_result of balance_updates
+  | Double_endorsement_evidence_result of balance_updates
+  | Double_baking_evidence_result of balance_updates
+  | Activation_result of balance_updates
+
+(** Result of applying a {!sourced_operation}.
+    Follows the same structure, except for [Manager_operations_result]
+    which includes the results of internal operations, in execution order. *)
+and sourced_operation_result =
+  | Consensus_operation_result of consensus_operation_result
+  | Amendment_operation_result
+  | Manager_operations_result of
+      { balance_updates : balance_updates ;
+        operation_results : (manager_operation_kind * manager_operation_result) list }
+  | Dictator_operation_result
+
+(** Result of applying a {!consensus_operation}. Follows the same structure. *)
+and consensus_operation_result =
+  | Endorsements_result of Signature.Public_key_hash.t * int list
+
+(** An operation descriptor in the queue of emitted manager
+    operations. [External] points to a {!manager_operation_content} in
+    the toplevel {!manager_operation}. The operations are executed in a
+    queue, so the n-th [External] corresponds to the [n-th]
+    {!manager_operation_content}. [Internal] points to an operation
+    emitted by a contract, whose contents is given verbatim. *)
+and manager_operation_kind =
+  | External
+  | Internal of internal_operation
+
+(** The result of an operation in the queue. [Skipped] ones should
+    always be at the tail, and after a single [Failed]. *)
+and manager_operation_result =
+  | Applied of successful_manager_operation_result
+  | Failed of error list
+  | Skipped
+
+(** Result of applying a {!manager_operation_content}, either internal
+    or external. *)
+and successful_manager_operation_result =
+  | Reveal_result
+  | Transaction_result of
+      { operations : internal_operation list ;
+        storage : Script.expr option ;
+        balance_updates : balance_updates ;
+        originated_contracts : Contract.t list ;
+        consumed_gas : Z.t ;
+        storage_fees_increment : Tez.t }
+  | Origination_result of
+      { balance_updates : balance_updates ;
+        originated_contracts : Contract.t list ;
+        consumed_gas : Z.t ;
+        storage_fees_increment : Tez.t }
+  | Delegation_result
+
+(** Serializer for {!proto_operation_result}. *)
+val encoding : operation_result Data_encoding.t

src/proto_alpha/lib_protocol/src/fees.ml

@@ -29,7 +29,8 @@ let origination_burn c ~payer contract =
   Contract.fees c contract >>=? fun fees ->
   trace Cannot_pay_storage_fee
     (Contract.spend_from_script c payer fees >>=? fun c ->
-     Contract.add_to_paid_fees c contract fees)
+     Contract.add_to_paid_fees c contract fees) >>=? fun c ->
+  return (c, fees)
 
 let update_script_storage c ~payer contract =
   Contract.paid_fees c contract >>=? fun paid_fees ->

src/proto_alpha/lib_protocol/src/fees.mli

@@ -13,7 +13,7 @@ type error += Cannot_pay_storage_fee
 
 val origination_burn:
   Alpha_context.t -> payer:Contract.t ->
-  Contract.t -> Alpha_context.t tzresult Lwt.t
+  Contract.t -> (Alpha_context.t * Tez.t) tzresult Lwt.t
 
 val update_script_storage:
   Alpha_context.t -> payer:Contract.t ->

src/proto_alpha/lib_protocol/src/helpers_services.ml

@@ -51,10 +51,7 @@ module S = struct
                  (req "operation_hash" Operation_hash.encoding)
                  (req "forged_operation" bytes)
                  (opt "signature" Signature.encoding))
-      ~output: (obj3
+      ~output: Apply_operation_result.encoding
-                  (req "contracts" (list Contract.encoding))
-                  (req "internal_operations" (list Operation.internal_operation_encoding))
-                  (req "remaining_gas" Gas.encoding))
       RPC_path.(custom_root / "apply_operation")
 
   let trace_code =
@@ -150,10 +147,7 @@ module I = struct
         let block_prio = 0 in
         Apply.apply_operation
           ctxt (Some baker_pkh) pred_block block_prio hash operation
-        >>=? function
+        >>=? fun (_, result) -> return result
-        | { ignored_error = Some script_err ; _ } -> Lwt.return (Error script_err)
-        | { gas ; contracts ; internal_operations ; _ } ->
-            Lwt.return (Ok (contracts, internal_operations, gas))
 
 end
 

src/proto_alpha/lib_protocol/src/helpers_services.mli

@@ -19,7 +19,7 @@ val minimal_time:
 val apply_operation:
   'a #RPC_context.simple ->
   'a -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Signature.t option ->
-  (Contract.t list * internal_operation list * Gas.t) shell_tzresult Lwt.t
+  Apply_operation_result.operation_result shell_tzresult Lwt.t
 
 val run_code:
   'a #RPC_context.simple ->

src/proto_alpha/lib_protocol/src/main.ml

@@ -116,7 +116,7 @@ let apply_operation ({ mode ; ctxt ; op_count ; _ } as data) operation =
         Some baker in
   Apply.apply_operation ctxt baker pred_block block_prio
     (Alpha_context.Operation.hash operation) operation
-  >>=? fun { Apply.ctxt ; _ } ->
+  >>=? fun (ctxt, _) ->
   let op_count = op_count + 1 in
   return { data with ctxt ; op_count }
 

src/proto_alpha/lib_protocol/src/script_interpreter.ml

@@ -166,7 +166,7 @@ let rec interp
               ~script:({ code ; storage }, None (* TODO: initialize a big map from a map *))
               ~spendable ~delegatable
             >>=? fun (ctxt, contract) ->
-            Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
+            Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, _) ->
             logged_return descr (Item ((param_type, contract), rest), ctxt) in
         let logged_return :
           a stack * context ->
@@ -676,7 +676,7 @@ let rec interp
             Contract.originate ctxt
               ~manager ~delegate ~balance
               ?script:None ~spendable:true ~delegatable >>=? fun (ctxt, contract) ->
-            Fees.origination_burn ctxt ~payer contract >>=? fun ctxt ->
+            Fees.origination_burn ctxt ~payer contract >>=? fun (ctxt, _) ->
             logged_return (Item ((Unit_t, contract), rest), ctxt)
         | Implicit_account, Item (key, rest) ->
             Lwt.return (Gas.consume ctxt Interp_costs.implicit_account) >>=? fun ctxt ->

src/proto_alpha/lib_protocol/test/helpers/helpers_apply.ml

@@ -8,6 +8,29 @@
 (**************************************************************************)
 
 open Proto_alpha.Error_monad
+open Proto_alpha.Apply_operation_result
+
+let extract_result = function
+  | Sourced_operation_result (Manager_operations_result { operation_results }) ->
+      List.fold_left
+        (fun (acc, err) (_, r) ->
+           match r with
+           | Applied (Transaction_result { originated_contracts }
+                     | Origination_result { originated_contracts }) ->
+               (originated_contracts @ acc, err)
+           | Applied Reveal_result
+           | Applied Delegation_result
+           | Skipped -> (acc, err)
+           | Failed errs -> (acc, Some errs))
+        ([], None) operation_results
+  | _ -> ([], None)
+
+let bind_result (tc, result) =
+  match extract_result result with
+  | _, Some err ->
+      Lwt.return (Error err)
+  | contracts, None ->
+      return (contracts, tc)
 
 let operation
     ~tc ?(baker: Helpers_account.t option) ?(src: Helpers_account.t option)
@@ -20,8 +43,8 @@ let operation
     pred_block_hash
     0
     hash
-    operation >>=? fun { ctxt = tc ; contracts ; ignored_error } ->
+    operation
-  return ((contracts, ignored_error), tc)
+  >>=? bind_result
 
 
 let transaction ~tc ?(fee = 0) ?baker

src/proto_alpha/lib_protocol/test/helpers/helpers_apply.mli

@@ -15,44 +15,44 @@ open Alpha_context
 val operation :
   tc:context -> ?baker:Helpers_account.t -> ?src:Helpers_account.t ->
   Block_hash.t -> Tezos_base.Operation.shell_header -> proto_operation ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val transaction :
   tc:context -> ?fee:int -> ?baker:Helpers_account.t -> Block_hash.t ->
   Tezos_base.Operation.shell_header -> Helpers_account.t -> Helpers_account.t -> int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val transaction_pred :
   ?tc:t -> pred:Helpers_block.result -> ?baker:Helpers_account.t ->
   Helpers_account.t * Helpers_account.t * int * int option ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val script_origination :
   tc:context -> Block_hash.t -> Tezos_base.Operation.shell_header ->
   Script.t option -> Helpers_account.t -> int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val origination :
   tc:context -> ?baker:Helpers_account.t -> ?spendable:bool -> ?fee:int ->
   ?delegatable:bool -> Block_hash.t -> Tezos_base.Operation.shell_header ->
   Helpers_account.t -> int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val script_origination_pred :
   ?tc:t -> pred:Helpers_block.result -> Script.t * Helpers_account.t * int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val origination_pred :
   ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
   Helpers_account.t * int * bool * bool * int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val delegation :
   tc:context -> ?baker:Helpers_account.t -> ?fee:int -> Block_hash.t ->
   Tezos_base.Operation.shell_header -> Helpers_account.t -> public_key_hash ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t
 
 val delegation_pred :
   ?tc:t -> ?baker:Helpers_account.t -> pred:Helpers_block.result ->
   Helpers_account.t * public_key_hash * int ->
-  ((Contract.contract list * proto_error list option) * context) proto_tzresult Lwt.t
+  (Contract.contract list * context) proto_tzresult Lwt.t

src/proto_alpha/lib_protocol/test/helpers/helpers_script.ml

@@ -18,7 +18,7 @@ let execute_code_pred
   let op = List.nth Helpers_account.bootstrap_accounts 0 in
   let tc = Option.unopt ~default:pred.tezos_context tc in
   Helpers_apply.script_origination_pred ~tc ~pred (script, op, init_amount)
-  >>=? fun ((dst, _), tc) ->
+  >>=? fun (dst, tc) ->
   let dst = List.hd dst in
   let ctxt = Helpers_cast.ctxt_of_tc tc in
   let gas = Proto_alpha.Alpha_context.Constants.hard_gas_limit_per_operation tc in

src/proto_alpha/lib_protocol/test/test_big_maps.ml

@@ -73,11 +73,7 @@ let main () =
   let src = List.hd Helpers.Account.bootstrap_accounts in
   Lwt.return (parse_script code storage) >>=? fun script ->
   Helpers.Apply.script_origination_pred
-    ~tc ~pred (script , src, 100_00) >>=?? fun ((contracts, errs), tc) ->
+    ~tc ~pred (script , src, 100_00) >>=?? fun (contracts, tc) ->
-  begin match errs with
-    | None | Some [] -> Proto_alpha.Error_monad.return ()
-    | Some (err :: _) -> Proto_alpha.Error_monad.fail err
-  end >>=?? fun () ->
   begin match contracts with
     | [ contract ] -> return contract
     | _ -> failwith "more than one contract"
@@ -103,11 +99,7 @@ let main () =
     Helpers.Apply.operation ~tc
       ~src pred.Helpers_block.hash
       (Helpers_block.get_op_header_res pred)
-      op >>=?? fun ((_, errs), tc) ->
+      op >>=?? fun (_, tc) ->
-    begin match errs with
-      | None | Some [] -> Proto_alpha.Error_monad.return ()
-      | Some (err :: _) -> Proto_alpha.Error_monad.fail err
-    end >>=?? fun () ->
     expect_big_map tc result >>=?? fun () ->
     debug "big map after call %s is ok" input ;
     return tc in

src/proto_alpha/lib_protocol/test/test_dsl.ml

@@ -52,7 +52,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
   transfer
     account_a
     account_unknown_foo
-    10000 >>= Assert.ok_contract >>=? fun (_, tc) ->
+    10000 >>= Assert.ok >>=? fun (_, tc) ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
   debug "Reception" ;
 
@@ -62,7 +62,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
     account_a
     account_b
     1000
-  >>=? fun ((contracts, _), _) ->
+  >>=? fun (contracts, _) ->
   Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
   debug "No contracts originated" ;
 
@@ -71,7 +71,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
     account_a
     account_b
     1000
-  >>= Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) ->
+  >>= Assert.ok ~msg: __LOC__ >>=? fun (_,tc) ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, 998990) >>=? fun () ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () ->
   debug "Transfer balances" ;
@@ -90,7 +90,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
     ~spendable: false
     account_a
     1000
-  >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) ->
+  >>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, tc) ->
   Assert.equal_int (List.length contracts) 1 ;
   let non_spendable = List.hd contracts in
   let account = {account_a with contract = non_spendable} in
@@ -105,7 +105,7 @@ let test_dsl () : unit proto_tzresult Lwt.t =
     ~fee: 100
     account_a
     1000
-  >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) ->
+  >>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, spendable_tc) ->
   Assert.equal_int (List.length contracts) 1 ;
   let contract_spendable = List.hd contracts in
   let account_spendable = {account_a with contract = contract_spendable} in

src/proto_alpha/lib_protocol/test/test_michelson.ml

@@ -8,7 +8,6 @@
 (**************************************************************************)
 
 open Proto_alpha
-open Alpha_context
 
 let name = "Isolate Michelson"
 module Logger = Logging.Make(struct let name = name end)
@@ -44,6 +43,21 @@ let program param st code =
 
 let quote s = "\"" ^ s ^ "\""
 
+open Apply_operation_result
+
+let extract_result rs =
+  List.fold_left
+    (fun (acc, err) (_, r) ->
+       match r with
+       | Applied (Transaction_result { originated_contracts }
+                 | Origination_result { originated_contracts }) ->
+           (originated_contracts @ acc, err)
+       | Applied Reveal_result
+       | Applied Delegation_result
+       | Skipped -> (acc, err)
+       | Failed errs -> (acc, errs))
+    ([], []) rs
+
 let parse_execute sb ?tc code_str param_str storage_str =
   let param = parse_param param_str in
   let script = parse_script code_str storage_str in
@@ -51,17 +65,17 @@ let parse_execute sb ?tc code_str param_str storage_str =
   >>=?? fun (dst, { ctxt = tc ; operations = ops ; big_map_diff = bgm }) ->
   let payer =
     (List.hd Account.bootstrap_accounts).contract in
-  Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>=?? fun (tc, err, _, ops) ->
+  Proto_alpha.Apply.apply_internal_manager_operations tc ~payer ops >>= function
-  Contract.originated_from_current_nonce tc >>=?? fun contracts ->
+  | Error result ->
-  match err with
+      let _, err = extract_result result in
-  | None ->
+      Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err)))
+  | Ok (tc, _) ->
+      Proto_alpha.Alpha_context.Contract.originated_from_current_nonce tc >>=?? fun contracts ->
       let tc = Proto_alpha.Alpha_context.Gas.set_unlimited tc in
       Proto_alpha.Alpha_context.Contract.get_storage tc dst >>=?? begin function
         | (_, None) -> assert false
         | (tc, Some st) -> return (st, ops, tc, contracts, bgm)
       end
-  | Some err ->
-      Lwt.return (Alpha_environment.wrap_error (Error_monad.error (List.hd err)))
 
 let test ctxt ?tc (file_name: string) (storage: string) (input: string) =
   let full_path = contract_path // file_name ^ ".tz" in

src/proto_alpha/lib_protocol/test/test_origination.ml

@@ -56,14 +56,14 @@ let test_delegation () =
 
   (* Delegatable should change delegate *)
   originate root ~delegatable: true account_a 200
-  >>=? fun ((contracts, _errs), tc) ->
+  >>=? fun (contracts, tc) ->
   let contract = List.hd contracts in
   let account_ac = {account_a with contract} in
   delegate root ~tc account_ac account_b.hpub >>= Assert.ok ~msg: __LOC__ >>= fun _ ->
 
   (* Not-Delegatable should not change delegate *)
   originate root ~delegatable: false account_a 200
-  >>=? fun ((contracts, _errs), tc) ->
+  >>=? fun (contracts, tc) ->
   let contract = List.hd contracts in
   let account_a = {account_a with contract} in
   delegate root ~tc account_a account_b.hpub >>= Assert.wrap >>= fun res ->

src/proto_alpha/lib_protocol/test/test_transaction.ml

@@ -48,23 +48,23 @@ let test_basic (): unit tzresult Lwt.t =
 
   (* Send 10 tz to unknown account. *)
   transfer (account_a, account_unknown_foo, 10000) >>=
-  Assert.ok_contract >>=? fun (_, tc) ->
+  Assert.ok >>=? fun (_, tc) ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_unknown_foo.contract, 10000) >>=? fun () ->
   debug "Reception" ;
 
   (* Unknown account transfers back tz. *)
   transfer ~tc (account_unknown_foo, account_a, 9990) >>=
-  Assert.ok_contract >>=? fun _ ->
+  Assert.ok >>=? fun _ ->
   debug "Transfer back" ;
 
   (* Check that a basic transfer originates no contracts. *)
-  transfer (account_a, account_b, 1000) >>=? fun ((contracts, _), _) ->
+  transfer (account_a, account_b, 1000) >>=? fun (contracts, _) ->
   Assert.equal_int ~msg: __LOC__ 0 (List.length contracts) ;
   debug "No contracts originated" ;
 
   (* Check sender/receiver balance post transaction *)
   transfer (account_a, account_b, 1000) >>=
-  Assert.ok_contract ~msg: __LOC__ >>=? fun (_,tc) ->
+  Assert.ok ~msg: __LOC__ >>=? fun (_,tc) ->
   Proto_alpha.Alpha_context.Contract.get_balance tc account_a.contract >>=? fun _balance ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_a.contract, init_amount * 100 - 1000 - 10) >>=? fun () ->
   Assert.equal_cents_balance ~msg: __LOC__ ~tc (account_b.contract, 1001000) >>=? fun () ->
@@ -78,7 +78,7 @@ let test_basic (): unit tzresult Lwt.t =
   (* Check non-spendability of a non-spendable contract *)
   (* TODO: Unspecified economic error: should be more specific. *)
   originate (account_a, 1000, false, true, 0)
-  >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts,_), tc) ->
+  >>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, tc) ->
   Assert.equal_int (List.length contracts) 1 ;
   let non_spendable = List.hd contracts in
   let account = {account_a with contract = non_spendable} in
@@ -90,7 +90,7 @@ let test_basic (): unit tzresult Lwt.t =
 
   (* Check spendability of a spendable contract *)
   originate (account_a, 1000, true, true, 100)
-  >>= Assert.ok_contract ~msg: __LOC__ >>=? fun ((contracts, _), spendable_tc) ->
+  >>= Assert.ok ~msg: __LOC__ >>=? fun (contracts, spendable_tc) ->
   Assert.equal_int (List.length contracts) 1 ;
   let contract_spendable = List.hd contracts in
   let account_spendable = {account_a with contract = contract_spendable} in