trying to improve output's readability

src/1_base/exc.ml

@@ -28,8 +28,11 @@ module Protocol = struct
         | Tezos blah -> fprintf fmt "%s" blah
         | MutezOvrflw blah -> fprintf fmt "mutez operation overflow: %s" blah
         | TooPoor (src, tgt, mutez) ->
-            fprintf fmt "insufficient balance to process transaction from %s to %s of %s mutez"
-                src tgt (Int64.to_string mutez)
+            fprintf fmt
+                "@[<hov>insufficient balance to process transaction of %s mutez"
+                (Int64.to_string mutez) ;
+            fprintf fmt "@ from %s" src ;
+            fprintf fmt "@ to %s@]" tgt
 end
 
 type exc =

src/1_base/mic.ml

@@ -526,10 +526,22 @@ let rec fmt_extension
     | SpawnContract dtyp -> fprintf fmtt "SPAWN_CONTRACT%a %a" annots () Dtyp.fmt dtyp
 
 (* Formats contracts. *)
-and fmt_contract (fmtt : formatter) ({ storage ; param ; entry } : contract) : unit =
+and fmt_contract
+    ~(full : bool)
+    (fmtt : formatter)
+    ({ storage ; param ; entry } : contract)
+    : unit
+=
     fprintf
-        fmtt "@[@[<v 4>{@ storage %a ;@ parameter %a ;@ code @[%a@] ;@]@,}@]"
-        Dtyp.fmt storage Dtyp.fmt param fmt entry
+        fmtt "@[@[<v 4>{@ storage %a ;@ parameter %a ;@ code "
+        Dtyp.fmt storage Dtyp.fmt param ;
+    (
+        if full then
+            fprintf fmtt "@[%a@]" fmt entry
+        else
+            fprintf fmtt "..."
+    );
+    fprintf fmtt ";@]@,}@]"
 
 (*  Formats constants.
 
@@ -544,7 +556,7 @@ and fmt_const (fmtt : formatter) (c : const) : unit =
     | Int n -> fprintf fmtt "%s" n
     | Str s -> fprintf fmtt "%S" s
     | Bytes s -> fprintf fmtt "0x%s" s
-    | Cont c -> fmt_contract fmtt c
+    | Cont c -> fmt_contract ~full:false fmtt c
     | Lft c -> fprintf fmtt "(Left %a)" fmt_const c
     | Rgt c -> fprintf fmtt "(Right %a)" fmt_const c
     | No -> fprintf fmtt "None"

src/1_base/mic.mli

@@ -254,8 +254,11 @@ val fmt_extension :
     extension ->
     unit
 
-(** Contract formatter. *)
-val fmt_contract : formatter -> contract -> unit
+(** Contract formatter.
+
+    If `full` is true, the code of the contract will be printed, otherwise it will appear as `...`.
+*)
+val fmt_contract : full : bool -> formatter -> contract -> unit
 
 (** Constant formatter. *)
 val fmt_const : formatter -> const -> unit

src/4_theory/make.ml

@@ -476,7 +476,7 @@ module Theory (
             fprintf fmtt " (%a)" (fmt_operation op_uid) operation
         | Create (params, contract) ->
             fprintf fmtt "@[<hv 4>CREATE[uid:%i] %a %a@]"
-                uid fmt_contract_params params Mic.fmt_contract contract
+                uid fmt_contract_params params (Mic.fmt_contract ~full:false) contract
         | CreateNamed (params, contract) ->
             fprintf fmtt "@[<hv 4>CREATE[uid:%i] %a \"%s\"@]"
                 uid fmt_contract_params params contract.name

src/5_stack/contracts.ml

@@ -127,19 +127,28 @@ module Contracts (T : Theo.Sigs.Theory) : Sigs.ContractEnv with module Theory =
             try Some (Hashtbl.find self.live (Theory.Address.uid address)) with
             | Not_found -> None
 
-        let transfer ~(src : string) (tez : Theory.Tez.t) (live : live) : unit =
+        let transfer ~(src : live option) (tez : Theory.Tez.t) (live : live) : unit =
             (fun () -> live.balance <- Theory.Tez.add live.balance tez)
-            |> Exc.chain_err (
-                fun () ->
-                    asprintf "while transfering %a from %s to live contract %a"
-                        Theory.Tez.fmt tez src fmt live
+            |> Exc.chain_errs (
+                fun () -> [
+                    asprintf "while transfering %a" Theory.Tez.fmt tez ;
+                    (
+                        match src with
+                        | None -> asprintf "from top-level testcase"
+                        | Some src -> asprintf "from live contract %a" fmt src
+                    );
+                    asprintf "to live contract %a" fmt live ;
+                ]
             )
 
-        let collect ~(tgt : string) (tez : Theory.Tez.t) (live : live) : unit =
+        let collect ~(tgt : live) (tez : Theory.Tez.t) (live : live) : unit =
             if Theory.Tez.compare live.balance tez >= 0 then (
                 live.balance <- Theory.Tez.sub live.balance tez
             ) else
-                Exc.Throw.too_poor ~src:live.contract.name ~tgt ~amount:(Theory.Tez.to_native tez)
+                Exc.Throw.too_poor
+                    ~src:(asprintf "%a" fmt live)
+                    ~tgt:(asprintf "%a" fmt tgt)
+                    ~amount:(Theory.Tez.to_native tez)
 
         let set_delegate (delegate : Theory.KeyH.t option) (self : live) : unit =
             Theory.set_delegate delegate self.params

src/5_stack/sigs.mli

@@ -110,10 +110,10 @@ module type ContractEnv = sig
         val count : t -> int
 
         (** Transfers some money to a live contract. *)
-        val transfer : src : string -> Theory.Tez.t -> live -> unit
+        val transfer : src : live option -> Theory.Tez.t -> live -> unit
 
         (** Collects some money from a live contract. *)
-        val collect : tgt : string -> Theory.Tez.t -> live -> unit
+        val collect : tgt : live -> Theory.Tez.t -> live -> unit
 
         (** Updates a live contract.
 

src/7_test/make.ml

@@ -189,9 +189,8 @@ module TestCxt (
                 fmt_operations self.test_ops;
             fprintf fmt "@]"
 
-        let next_op (self : apply_ops) : Env.operation option =
-            let op = Lst.hd self.ops in
-            if op <> None then op else Lst.hd self.test_ops
+        let fmt_contracts (fmt : formatter) (self : apply_ops) : unit =
+            fmt_contracts fmt (contract_env self)
 
         let pop_next_op (self : apply_ops) : Env.operation option =
             match self.ops with
@@ -207,6 +206,26 @@ module TestCxt (
                 Some op
             | [] -> None
 
+        (* Returns the next operation.
+
+            The only side effect this function can have is if
+            - `self.ops` is empty, and
+            - `self.test_ops` is `test_op :: tail`.
+
+            Then `self.ops <- [test_op]` and `self.test_ops <- tail`. This is semantics preserving:
+            the next test operation is staged, but no operation is lost (popped). This is why these
+            details are not discussed in the `mli`'s doc for this function.
+        *)
+        let next_op (self : apply_ops) : Env.operation option =
+            let op = Lst.hd self.ops in
+            if op <> None then op else (
+                match pop_next_test_op self with
+                | None -> None
+                | Some op ->
+                    self.ops <- [op];
+                    Some op
+            )
+
         let stage_next_test_op (self : apply_ops) : (run_test, transfer) Either.t option =
             self.ops <- [];
             match pop_next_test_op self with
@@ -446,12 +465,12 @@ module TestCxt (
                                     |> Exc.throw
                                 | Some live -> live
                             in
-                            let src : string =
+                            let src =
                                 match Run.Env.Live.get sender contract_env with
                                 | Some src ->
-                                    Run.Env.Live.collect ~tgt:tgt.contract.name amount src;
-                                    src.contract.name
-                                | None -> "testcase"
+                                    Run.Env.Live.collect ~tgt:tgt amount src;
+                                    Some src
+                                | None -> None
                             in
 
                             Run.Env.Live.transfer ~src amount tgt;
@@ -586,5 +605,11 @@ module TestCxt (
                 fmt_operations self.ops
                 fmt_operations self.test_ops;
             fprintf fmt "@]"
+
+        let fmt_op (fmt : formatter) (self : transfer) : unit =
+            fprintf fmt "%a" Env.Op.fmt self.op                        
+
+        let fmt_contracts (fmt : formatter) (self : transfer) : unit =
+            fmt_contracts fmt (contract_env self)
     end
 end

src/7_test/sigs.mli

@@ -115,12 +115,15 @@ module type TestCxt = sig
         (** The next operation to apply. *)
         val next_op : apply_ops -> Env.operation option
 
-        (** Concise `run_test` formatter.
+        (** Concise `apply_ops` formatter.
 
             This formatter only outputs live contracts and pending operations. For a more verbose
             output, use the accessors.
         *)
         val fmt : formatter -> apply_ops -> unit
+
+        (** Formats the live contract in the environment. *)
+        val fmt_contracts : formatter -> apply_ops -> unit
     end
 
     (** Contains the operations related to `transfer`. *)
@@ -143,11 +146,17 @@ module type TestCxt = sig
         (** The contract environment. *)
         val contract_env : transfer -> Env.t
 
-        (** Concise `run_test` formatter.
+        (** Concise `transfer` formatter.
         
             This formatter only outputs live contracts and pending operations. For a more verbose
             output, use the accessors.
         *)
         val fmt : formatter -> transfer -> unit
+
+        (** Formats the operation the transfer is for. *)
+        val fmt_op : formatter -> transfer -> unit
+
+        (** Formats the live contract in the environment. *)
+        val fmt_contracts : formatter -> transfer -> unit
     end
 end

src/main.ml

@@ -1,10 +1,8 @@
 open Base
-open Base.Common
 
 (* Set configuration from CLAP and print it. *)
 let _ =
-    Clap.set_conf ();
-    conf () |> log_4 "@[<v>Configuration:@,%a@]@.@." Conf.fmt
+    Clap.set_conf ()
 
 (* Actually do stuff. *)
 let _ =

src/run.ml

@@ -84,45 +84,55 @@ let run_tests (conf : Conf.t) (cxt : Test.Testcases.t) : unit =
             let cxt = Cxt.init (Tests.get_contracts cxt) test in
 
             let rec test_loop (cxt : Cxt.run_test) : unit =
-                log_1 "Running test script...@.";
-                log_3 "%a@." Cxt.Test.fmt cxt;
+                log_1 "@.running test script...@.";
+                log_2 "context: %a@." Cxt.Test.fmt cxt;
                 cond_step conf;
                 let events, next_state = Cxt.Test.run cxt in
                 let is_done = handle_events conf (Cxt.Test.stack cxt) events in
                 match next_state with
                 | Some _ when is_done -> Exc.throws [
                     "inconsistent internal state" ;
-                    "test code is done but there are still operations to process" ;
+                    "testcase is done but there are still operations to process" ;
                 ]
                 | Some ops -> ops_loop ops
                 | None when is_done -> log_1 "Done running test `%s`@." test.name
                 | None -> test_loop cxt
 
             and ops_loop (cxt : Cxt.apply_ops) : unit =
-                log_1 "@.Applying Operations...@.";
-                log_3 "%a@." Cxt.Ops.fmt cxt;
-                (
-                    match Cxt.Ops.next_op cxt with
-                    | Some op -> log_2 "> %a@." Cxt.Env.Op.fmt op
-                    | None -> log_2 "> <none>@."
-                );
-                cond_step conf;
+                log_1 "@.";
                 let rec loop () =
-                    match Cxt.Ops.apply cxt with
-                    | Some (Either.Lft test) -> test_loop test
-                    | Some (Either.Rgt transfer) -> transfer_loop transfer
-                    | None -> loop ()
+                    (* log_0 "%a@." Cxt.Ops.fmt cxt; *)
+                    (
+                        match Cxt.Ops.next_op cxt with
+                        | Some op -> (
+                            log_1 "applying operation %a@." Cxt.Env.Op.fmt op;
+                            log_1 "   %a@." Cxt.Ops.fmt_contracts cxt;
+                        )
+                        | None -> log_2 "no operations left@."
+                    );
+                    cond_step conf;
+                    let res = Cxt.Ops.apply cxt in
+                    match res with
+                    | Some (Either.Lft test) ->
+                        log_1 "=> %a@." Cxt.Ops.fmt_contracts cxt;
+                        test_loop test
+                    | Some (Either.Rgt transfer) ->
+                        transfer_loop transfer
+                    | None ->
+                        log_1 "=> %a@." Cxt.Ops.fmt_contracts cxt;
+                        loop ()
                 in
                 loop ()
 
             and transfer_loop (cxt : Cxt.transfer) : unit =
+                log_1 "@.running %a@." Cxt.Transfer.fmt_op cxt;
                 if conf.step then (
                     let rec loop () : unit =
-                        log_0 "@.Contract Transfer Step...@.";
-                        log_3 "%a@." Cxt.Transfer.fmt cxt;
-                        Cxt.Transfer.interpreter cxt
+                        log_2 "@.Contract Transfer Step...";
+                        log_3 "context: %a@." Cxt.Transfer.fmt cxt;
+                        (* Cxt.Transfer.interpreter cxt
                         |> Cxt.Run.stack
-                        |> log_3 "@.@[<v>%a@]@.@." Cxt.Run.Stack.fmt;
+                        |> log_3 "@.@[<v>%a@]@.@." Cxt.Run.Stack.fmt; *)
                         Cxt.Transfer.interpreter cxt
                         |> Cxt.Run.next_ins
                         |> (
@@ -150,15 +160,19 @@ let run_tests (conf : Conf.t) (cxt : Test.Testcases.t) : unit =
                                     (not even empty)" ;
                                 ]
                             )
-                        | Some (Either.Rgt ops) -> ops_loop ops
+                        | Some (Either.Rgt ops) ->
+                            log_1 "=> %a@." Cxt.Transfer.fmt_contracts cxt;
+                            ops_loop ops
                     in
                     loop ()
                 ) else (
-                    log_1 "@.Contract Transfer...@.";
-                    log_3 "%a@." Cxt.Transfer.fmt cxt;
+                    (* log_1 "@.Contract Transfer...@."; *)
+                    (* log_3 "%a@." Cxt.Transfer.fmt cxt; *)
                     let rec loop () =
                         match Cxt.Transfer.run cxt with
-                        | Either.Rgt ops -> ops_loop ops
+                        | Either.Rgt ops ->
+                            log_1 "=> %a@." Cxt.Transfer.fmt_contracts cxt;
+                            ops_loop ops
                         | Either.Lft event ->
                             let is_done = handle_event conf (Cxt.Transfer.stack cxt) event in
                             if is_done then (
@@ -179,13 +193,14 @@ let run_tests (conf : Conf.t) (cxt : Test.Testcases.t) : unit =
                 err_count
             ) with
             | e ->
-                log_0 "Test `%s` failed:@.    @[%a@]@." test.name Exc.fmt e;
+                log_0 "@.Test `%s` failed:@.    @[%a@]@." test.name Exc.fmt e;
                 err_count + 1
     ) 0
     |> (
         function
         | 0 -> ()
         | n ->
+            log_0 "@.";
             let test_count = Tests.get_tests cxt |> List.length in
             sprintf "%i of the %i testcase%s failed" n test_count (Fmt.plurify test_count)
             |> Exc.throw