some more operators

src/ast_typed/combinators.ml

@@ -15,6 +15,8 @@ let make_n_t type_name type_value = { type_name ; type_value }
 let t_bool ?s () : type_value = make_t (T_constant ("bool", [])) s
 let t_string ?s () : type_value = make_t (T_constant ("string", [])) s
 let t_bytes ?s () : type_value = make_t (T_constant ("bytes", [])) s
+let t_key ?s () : type_value = make_t (T_constant ("key", [])) s
+let t_key_hash ?s () : type_value = make_t (T_constant ("key_hash", [])) s
 let t_int ?s () : type_value = make_t (T_constant ("int", [])) s
 let t_address ?s () : type_value = make_t (T_constant ("address", [])) s
 let t_operation ?s () : type_value = make_t (T_constant ("operation", [])) s
@@ -93,6 +95,18 @@ let get_t_list (t:type_value) : type_value result = match t.type_value' with
   | T_constant ("list", [o]) -> ok o
   | _ -> simple_fail "not a list"
 
+let get_t_key (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("key", []) -> ok ()
+  | _ -> simple_fail "not a key"
+
+let get_t_signature (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("signature", []) -> ok ()
+  | _ -> simple_fail "not a signature"
+
+let get_t_key_hash (t:type_value) : unit result = match t.type_value' with
+  | T_constant ("key_hash", []) -> ok ()
+  | _ -> simple_fail "not a key_hash"
+
 let get_t_tuple (t:type_value) : type_value list result = match t.type_value' with
   | T_tuple lst -> ok lst
   | _ -> simple_fail "not a tuple"
@@ -136,7 +150,10 @@ let assert_t_map = fun t ->
 
 let is_t_map = Function.compose to_bool get_t_map
 
-let assert_t_tez :type_value -> unit result = get_t_tez
+let assert_t_tez : type_value -> unit result = get_t_tez
+let assert_t_key = get_t_key
+let assert_t_signature = get_t_signature
+let assert_t_key_hash = get_t_key_hash
 
 let assert_t_list t =
   let%bind _ = get_t_list t in

src/compiler/compiler_program.ml

@@ -16,6 +16,16 @@ let get_predicate : string -> type_value -> expression list -> predicate result
   | Some x -> ok x
   | None -> (
       match s with
+      | "NONE" -> (
+          let%bind ty' = Mini_c.get_t_option ty in
+          let%bind m_ty = Compiler_type.type_ ty' in
+          ok @@ simple_unary @@ prim ~children:[m_ty] I_NONE
+        )
+      | "UNPACK" -> (
+          let%bind ty' = Mini_c.get_t_option ty in
+          let%bind m_ty = Compiler_type.type_ ty' in
+          ok @@ simple_unary @@ prim ~children:[m_ty] I_UNPACK
+        )
       | "MAP_REMOVE" ->
           let%bind v = match lst with
             | [ _ ; expr ] ->

src/operators/operators.ml

@@ -42,6 +42,9 @@ module Simplify = struct
     ("bool" , "bool") ;
     ("operation" , "operation") ;
     ("address" , "address") ;
+    ("key" , "key") ;
+    ("key_hash" , "key_hash") ;
+    ("signature" , "signature") ;
     ("timestamp" , "timestamp") ;
     ("contract" , "contract") ;
     ("list" , "list") ;
@@ -76,7 +79,7 @@ module Simplify = struct
       ("Bytes.pack" , "PACK") ;
       ("Crypto.hash" , "HASH") ;
       ("Operation.transaction" , "CALL") ;
-      ("Operation.get_contract" , "GET_CONTRACT") ;
+      ("Operation.get_contract" , "CONTRACT") ;
       ("sender" , "SENDER") ;
       ("unit" , "UNIT") ;
       ("source" , "SOURCE") ;
@@ -126,7 +129,7 @@ module Simplify = struct
       ("List.iter", "ITER") ;
 
       ("Operation.transaction" , "CALL") ;
-      ("Operation.get_contract" , "GET_CONTRACT") ;
+      ("Operation.get_contract" , "CONTRACT") ;
       ("int" , "INT") ;
       ("abs" , "ABS") ;
       ("unit" , "UNIT") ;
@@ -243,9 +246,15 @@ module Typer = struct
   let size = typer_1 "SIZE" @@ fun t ->
     let%bind () =
       Assert.assert_true @@
-      (is_t_map t || is_t_list t) in
+      (is_t_map t || is_t_list t || is_t_string t) in
     ok @@ t_nat ()
 
+  let slice = typer_3 "SLICE" @@ fun i j s ->
+    let%bind () =
+      Assert.assert_true @@
+      (is_t_nat i && is_t_nat j && is_t_string s) in
+    ok @@ t_string ()
+  
   let failwith_ = typer_1 "FAILWITH" @@ fun t ->
     let%bind () =
       Assert.assert_true @@
@@ -269,10 +278,28 @@ module Typer = struct
     trace_option (simple_error "untyped UNPACK") @@
     output_opt
 
-  let crypto_hash = typer_1 "HASH" @@ fun t ->
+  let hash256 = typer_1 "SHA256" @@ fun t ->
     let%bind () = assert_t_bytes t in
     ok @@ t_bytes ()
 
+  let hash512 = typer_1 "SHA512" @@ fun t ->
+    let%bind () = assert_t_bytes t in
+    ok @@ t_bytes ()
+
+  let blake2b = typer_1 "BLAKE2b" @@ fun t ->
+    let%bind () = assert_t_bytes t in
+    ok @@ t_bytes ()
+
+  let hash_key = typer_1 "HASH_KEY" @@ fun t ->
+    let%bind () = assert_t_key t in
+    ok @@ t_key_hash ()
+
+  let check_signature = typer_3 "CHECK_SIGNATURE" @@ fun k s b ->
+    let%bind () = assert_t_key k in
+    let%bind () = assert_t_signature s in
+    let%bind () = assert_t_bytes b in
+    ok @@ t_bool ()
+  
   let sender = constant "SENDER" @@ t_address ()
 
   let source = constant "SOURCE" @@ t_address ()
@@ -281,6 +308,8 @@ module Typer = struct
 
   let amount = constant "AMOUNT" @@ t_tez ()
 
+  let address = constant "ADDRESS" @@ t_address ()
+
   let now = constant "NOW" @@ t_timestamp ()
 
   let transaction = typer_3 "CALL" @@ fun param amount contract ->
@@ -367,7 +396,11 @@ module Typer = struct
       get_force ;
       bytes_pack ;
       bytes_unpack ;
-      crypto_hash ;
+      hash256 ;
+      hash512 ;
+      blake2b ;
+      hash_key ;
+      check_signature ;
       sender ;
       source ;
       unit ;
@@ -376,6 +409,8 @@ module Typer = struct
       get_contract ;
       abs ;
       now ;
+      slice ;
+      address ;
     ]
 
 end
@@ -407,6 +442,8 @@ module Compiler = struct
     ("NEG" , simple_unary @@ prim I_NEG) ;
     ("OR" , simple_binary @@ prim I_OR) ;
     ("AND" , simple_binary @@ prim I_AND) ;
+    ("XOR" , simple_binary @@ prim I_XOR) ;
+    ("NOT" , simple_unary @@ prim I_NOT) ;
     ("PAIR" , simple_binary @@ prim I_PAIR) ;
     ("CAR" , simple_unary @@ prim I_CAR) ;
     ("CDR" , simple_unary @@ prim I_CDR) ;
@@ -428,12 +465,22 @@ module Compiler = struct
     ("CONS" , simple_binary @@ prim I_CONS) ;
     ("UNIT" , simple_constant @@ prim I_UNIT) ;
     ("AMOUNT" , simple_constant @@ prim I_AMOUNT) ;
+    ("ADDRESS" , simple_constant @@ prim I_ADDRESS) ;
     ("NOW" , simple_constant @@ prim I_NOW) ;
     ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ;
     ("SOURCE" , simple_constant @@ prim I_SOURCE) ;
     ("SENDER" , simple_constant @@ prim I_SENDER) ;
-    ( "MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ;
+    ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE ]) ;
-    ( "MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ;
+    ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ;
+    ("SLICE" , simple_ternary @@ prim I_SLICE) ;
+    ("SHA256" , simple_unary @@ prim I_SHA256) ;
+    ("SHA512" , simple_unary @@ prim I_SHA512) ;
+    ("BLAKE2B" , simple_unary @@ prim I_BLAKE2B) ;
+    ("CHECK_SIGNATURE" , simple_ternary @@ prim I_CHECK_SIGNATURE) ;
+    ("HASH_KEY" , simple_unary @@ prim I_HASH_KEY) ;
+    ("PACK" , simple_unary @@ prim I_PACK) ;
   ]
 
+  (* Some complex predicates will need to be added in compiler/compiler_program *)
+  
 end

src/test/test_helpers.ml

@@ -5,7 +5,7 @@ type test =
   | Test_suite of (string * test list)
   | Test of test_case
 
-let error_pp out (e : error) =
+let rec error_pp out (e : error) =
     let open JSON_string_utils in
   let message =
     let opt = e |> member "message" |> string in
@@ -30,6 +30,7 @@ let error_pp out (e : error) =
     let infos = e |> member "infos" in
     match infos with
     | `Null -> ""
+    | `List lst -> Format.asprintf "@[<v2>%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst
     | _ -> " " ^ (J.to_string infos) ^ "\n" in
   Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos