more tests

src/lib_utils/PP.ml

@@ -38,9 +38,8 @@ let map = fun f pp ppf x ->
 let pair_sep value sep ppf (a, b) = fprintf ppf "%a %s %a" value a sep value b
 let smap_sep value sep ppf m =
   let module SMap = X_map.String in
-  let aux k v prev = (k, v) :: prev in
+  let lst = SMap.to_kv_list m in
   let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in
-  let lst = List.rev @@ SMap.fold aux m [] in
   fprintf ppf "%a" (list_sep new_pp sep) lst
 
 (* TODO: remove all uses. this is bad. *)

src/lib_utils/x_list.ml

@@ -115,7 +115,11 @@ let rev_uncons_opt = function
       let r = rev lst in
       let last = hd r in
       let hds = rev @@ tl r in
-      Some (hds, last)
+      Some (hds , last)
+
+let hds lst = match rev_uncons_opt lst with
+  | None -> failwith "toto"
+  | Some (hds , _) -> hds
 
 let to_pair = function
   | [a ; b] -> Some (a , b)

src/ligo/ast_simplified/PP.ml

@@ -2,8 +2,14 @@ open Types
 open PP_helpers
 open Format
 
-let list_sep_d x = list_sep x (const " , ")
-let smap_sep_d x = smap_sep x (const " , ")
+let list_sep_d x ppf lst = match lst with
+  | [] -> ()
+  | _ -> fprintf ppf "@;  @[<v>%a@]@;" (list_sep x (tag "@;")) lst
+
+let smap_sep_d x ppf m =
+  if Map.String.is_empty m
+  then ()
+  else fprintf ppf "@;  @[<v>%a@]@;" (smap_sep x (tag "@;")) m
 
 let rec type_expression ppf (te:type_expression) = match te with
   | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst
@@ -22,6 +28,7 @@ let literal ppf (l:literal) = match l with
   | Literal_string s -> fprintf ppf "%S" s
   | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
   | Literal_address s -> fprintf ppf "@%S" s
+  | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
 
 let rec expression ppf (e:expression) = match e with
   | E_literal l -> literal ppf l

src/ligo/ast_simplified/combinators.ml

@@ -171,3 +171,13 @@ let get_access_record : access -> string result = fun a ->
   | Access_tuple _
   | Access_map _ -> simple_fail "not an access record"
   | Access_record s -> ok s
+
+let get_a_pair = fun t ->
+  match t.expression with
+  | E_tuple [a ; b] -> ok (a , b)
+  | _ -> simple_fail "not a pair"
+
+let get_a_list = fun t ->
+  match t.expression with
+  | E_list lst -> ok lst
+  | _ -> simple_fail "not a pair"

src/ligo/ast_simplified/misc.ml

@@ -26,10 +26,13 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_address a, Literal_address b when a = b -> ok ()
   | Literal_address _, Literal_address _ -> simple_fail "different addresss"
   | Literal_address _, _ -> simple_fail "address vs non-address"
+  | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations"
+  | Literal_operation _, _ -> simple_fail "operation vs non-operation"
+
 
 let rec assert_value_eq (a, b: (value*value)) : unit result =
   let error_content () =
-    Format.asprintf "%a vs %a" PP.value a PP.value b
+    Format.asprintf "\n@[<v>- %a@;- %a]" PP.value a PP.value b
   in
   trace (fun () -> error (thunk "not equal") error_content ()) @@
   match (a.expression, b.expression) with

src/ligo/ast_simplified/types.ml

@@ -88,6 +88,7 @@ and literal =
   | Literal_string of string
   | Literal_bytes of bytes
   | Literal_address of string
+  | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
 
 and block = instruction list
 and b = block

src/ligo/ast_typed/PP.ml

@@ -63,6 +63,7 @@ and literal ppf (l:literal) : unit =
   | Literal_string s -> fprintf ppf "%s" s
   | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b
   | Literal_address s -> fprintf ppf "@%s" s
+  | Literal_operation _ -> fprintf ppf "Operation(...bytes)"
 
 and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b
 

src/ligo/ast_typed/combinators.ml

@@ -155,6 +155,7 @@ let e_tez n : expression = E_literal (Literal_tez n)
 let e_bool b : expression = E_literal (Literal_bool b)
 let e_string s : expression = E_literal (Literal_string s)
 let e_address s : expression = E_literal (Literal_address s)
+let e_operation s : expression = E_literal (Literal_operation s)
 let e_pair a b : expression = E_tuple [a; b]
 let e_list lst : expression = E_list lst
 

src/ligo/ast_typed/misc.ml

@@ -276,11 +276,13 @@ let assert_literal_eq (a, b : literal * literal) : unit result =
   | Literal_address a, Literal_address b when a = b -> ok ()
   | Literal_address _, Literal_address _ -> simple_fail "different addresss"
   | Literal_address _, _ -> simple_fail "address vs non-address"
+  | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations"
+  | Literal_operation _, _ -> simple_fail "operation vs non-operation"
 
 
 let rec assert_value_eq (a, b: (value*value)) : unit result =
   let error_content () =
-    Format.asprintf "%a vs %a" PP.value a PP.value b
+    Format.asprintf "\n%a vs %a" PP.value a PP.value b
   in
   trace (fun () -> error (thunk "not equal") error_content ()) @@
   match (a.expression, b.expression) with

src/ligo/ast_typed/types.ml

@@ -107,6 +107,7 @@ and literal =
   | Literal_string of string
   | Literal_bytes of bytes
   | Literal_address of string
+  | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
 
 and block = instruction list
 and b = block

src/ligo/compiler/compiler_program.ml

@@ -74,6 +74,8 @@ let rec translate_value (v:value) : michelson result = match v with
   | D_list lst ->
       let%bind lst' = bind_map_list translate_value lst in
       ok @@ seq lst'
+  | D_operation _ ->
+      simple_fail "can't compile an operation"
 
 and translate_function (content:anon_function) : michelson result =
   let%bind body = translate_quote_body content in

src/ligo/compiler/uncompiler.ml

@@ -72,6 +72,8 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result =
         bind_map_list aux lst'
       in
       ok @@ D_list lst''
+  | (Operation_t _) , op ->
+      ok @@ D_operation op
   | ty, v ->
       let%bind error =
         let%bind m_data =

src/ligo/mini_c/PP.ml

@@ -8,7 +8,6 @@ let space_sep ppf () = fprintf ppf " "
 
 let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R"
 
-
 let type_base ppf : type_base -> _ = function
   | Base_unit -> fprintf ppf "unit"
   | Base_bool -> fprintf ppf "bool"
@@ -42,6 +41,7 @@ and environment ppf (x:environment) =
 
 let rec value ppf : value -> unit = function
   | D_bool b -> fprintf ppf "%b" b
+  | D_operation _ -> fprintf ppf "operation[...bytes]"
   | D_int n -> fprintf ppf "%d" n
   | D_nat n -> fprintf ppf "+%d" n
   | D_tez n -> fprintf ppf "%dtz" n

src/ligo/mini_c/combinators.ml

@@ -115,6 +115,15 @@ let get_t_contract t = match t with
   | T_contract x -> ok x
   | _ -> fail @@ wrong_type "contract" t
 
+let get_t_operation t = match t with
+  | T_base Base_operation -> ok ()
+  | _ -> fail @@ wrong_type "operation" t
+
+let get_operation (v:value) = match v with
+  | D_operation x -> ok x
+  | _ -> simple_fail "not an operation"
+
+
 let get_last_statement ((b', _):block) : statement result =
   let aux lst = match lst with
     | [] -> simple_fail "get_last: empty list"

src/ligo/mini_c/types.ml

@@ -47,6 +47,7 @@ type value =
   | D_list of value list
   (* | `Macro of anon_macro ... The future. *)
   | D_function of anon_function
+  | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation
 
 and selector = var_name list
 

src/ligo/test/coase_tests.ml

@@ -164,23 +164,25 @@ let sell () =
       let sell_action = ez_e_a_record [
           ("card_to_sell" , e_a_nat (n - 1)) ;
         ] in
-      let storage = basic 100 1000 (cards_ez first_owner n) (2 * n) in
+      let cards = cards_ez first_owner n in
+      let storage = basic 100 1000 cards (2 * n) in
       e_a_pair sell_action storage
     in
-    let make_expected = fun n ->
-      let ops = e_a_list [] t_operation in
-      let storage =
-        let cards =
-          cards_ez first_owner n @
-          [(e_a_nat (2 * n) , card (e_a_address second_owner))]
-        in
-        basic 101 1000 cards ((2 * n) + 1) in
-      e_a_pair ops storage
+    let make_expecter : int -> annotated_expression -> unit result = fun n result ->
+      let%bind (ops , storage) = get_a_pair result in
+      let%bind () =
+        let%bind lst = get_a_list ops in
+        Assert.assert_list_size lst 1 in
+      let expected_storage =
+        let cards = List.hds @@ cards_ez first_owner n in
+        basic 99 1000 cards (2 * n) in
+      Ast_simplified.assert_value_eq (expected_storage , storage)
     in
     let%bind () =
       let amount = Memory_proto_alpha.Alpha_context.Tez.zero in
-      let options = Memory_proto_alpha.make_options ~amount () in
-      expect_eq_n_pos_small ~options program "sell_single" make_input make_expected in
+      let payer = first_contract in
+      let options = Memory_proto_alpha.make_options ~amount ~payer () in
+      expect_n_strict_pos_small ~options program "sell_single" make_input make_expecter in
     ok ()
   in
   ok ()
@@ -189,5 +191,5 @@ let sell () =
 let main = "Coase (End to End)", [
     test "buy" buy ;
     test "transfer" transfer ;
-    (* test "sell" sell ; *)
+    test "sell" sell ;
   ]

src/ligo/test/test_helpers.ml

@@ -78,6 +78,9 @@ let expect_eq_n_pos_small ?options = expect_eq_n_aux ?options [0 ; 2 ; 10]
 let expect_eq_n_strict_pos_small ?options = expect_eq_n_aux ?options [2 ; 10]
 let expect_eq_n_pos_mid = expect_eq_n_aux [0 ; 2 ; 10 ; 33]
 
+let expect_n_pos_small ?options = expect_n_aux ?options [0 ; 2 ; 10]
+let expect_n_strict_pos_small ?options = expect_n_aux ?options [2 ; 10]
+
 let expect_eq_b program entry_point make_expected =
   let aux b =
     let input = e_a_bool b in

src/ligo/transpiler/transpiler.ml

@@ -37,7 +37,12 @@ let rec translate_type (t:AST.type_value) : type_value result =
   | T_constant ("option", [o]) ->
       let%bind o' = translate_type o in
       ok (T_option o')
-  | T_constant (name, _) -> fail (fun () -> error (thunk "unrecognized type constant") (fun () -> name) ())
+  | T_constant (name , lst) ->
+      let error =
+        let title () = "unrecognized type constant" in
+        let content () = Format.asprintf "%s (%d)" name (List.length lst) in
+        error title content in
+      fail error
   | T_sum m ->
       let node = Append_tree.of_list @@ list_of_map m in
       let aux a b : type_value result =
@@ -203,6 +208,7 @@ and translate_literal : AST.literal -> value = fun l -> match l with
   | Literal_bytes s -> D_bytes s
   | Literal_string s -> D_string s
   | Literal_address s -> D_string s
+  | Literal_operation op -> D_operation op
   | Literal_unit -> D_unit
 
 and transpile_small_environment : AST.small_environment -> Environment.t result = fun x ->
@@ -636,8 +642,17 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression
         bind_map_list aux lst in
       return (E_list lst')
     )
-  | T_constant _ ->
-      simple_fail "unknown type_constant"
+  | T_constant ("contract" , [_ty]) ->
+      simple_fail "can't untranspile contract"
+  | T_constant ("operation" , []) ->
+      let%bind op = get_operation v in
+      return (E_literal (Literal_operation op))
+  | T_constant (name , lst) ->
+      let error =
+        let title () = "unknown type_constant" in
+        let content () = Format.asprintf "%s (%d)" name (List.length lst) in
+        error title content in
+      fail error
   | T_sum m ->
       let lst = kv_list_of_map m in
       let%bind node = match Append_tree.of_list lst with

src/ligo/typer/typer.ml

@@ -368,6 +368,8 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot
       return (E_literal (Literal_tez n)) (t_tez ())
   | E_literal (Literal_address s) ->
       return (e_address s) (t_address ())
+  | E_literal (Literal_operation op) ->
+      return (e_operation op) (t_operation ())
   (* Tuple *)
   | E_tuple lst ->
       let%bind lst' = bind_list @@ List.map (type_annotated_expression e) lst in
@@ -605,6 +607,7 @@ let untype_literal (l:O.literal) : I.literal result =
   | Literal_string s -> ok (Literal_string s)
   | Literal_bytes b -> ok (Literal_bytes b)
   | Literal_address s -> ok (Literal_address s)
+  | Literal_operation s -> ok (Literal_operation s)
 
 let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_expression) result =
   let open I in