open Trace (* This file is used throughout the pipeline. Its idea is to add a unique place that you have to modify when you add a new operator/constant to the language. This file mirrors the LIGO pipeline, starting with Simplify, then Typer and ending with Compiler. Usually, when adding a new operator, you'll have to add a new constructor at all those places. *) module Concrete_to_imperative = struct open Ast_imperative (* Each front-end has its owns constants. Constants are special names that have their own case in the AST. E_constant for regular constants, and T_constant for type constants. Both types are defined in `Ast_core/types.ml`. For instance, "2 + 2" in Pascaligo is translated to `E_constant ("ADD" , [ E_literal (Literal_int 2) ; E_literal (Literal_int 2) ; ])`. They are used to represent what can't expressed in the languages: - Primitives. Like "int", "string", "unit" for types. Or "+" for values. - Tezos specific stuff. Like "operation" for types. Or "source" for values. - What can't be represented in the language yet. Like "list" or "List.fold". Each constant is expressed as a pair: - The left-hand-side is the reserved name in the given front-end. - The right-hand-side is the name that will be used in the AST. *) let unit_expr = make_t @@ T_constant TC_unit let type_constants s = match s with "chain_id" -> Some TC_chain_id | "unit" -> Some TC_unit | "string" -> Some TC_string | "bytes" -> Some TC_bytes | "nat" -> Some TC_nat | "int" -> Some TC_int | "tez" -> Some TC_mutez | "operation" -> Some TC_operation | "address" -> Some TC_address | "key" -> Some TC_key | "key_hash" -> Some TC_key_hash | "signature" -> Some TC_signature | "timestamp" -> Some TC_timestamp | _ -> None let type_operators s = match s with "list" -> Some (TC_list unit_expr) | "option" -> Some (TC_option unit_expr) | "set" -> Some (TC_set unit_expr) | "map" -> Some (TC_map (unit_expr,unit_expr)) | "big_map" -> Some (TC_big_map (unit_expr,unit_expr)) | "contract" -> Some (TC_contract unit_expr) | "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb unit_expr) | "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb unit_expr) | "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb unit_expr) | "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb unit_expr) | _ -> None let pseudo_modules = function | "Tezos.chain_id" -> Some C_CHAIN_ID | "Tezos.balance" -> Some C_BALANCE | "Tezos.now" -> Some C_NOW | "Tezos.amount" -> Some C_AMOUNT | "Tezos.sender" -> Some C_SENDER | "Tezos.address" -> Some C_ADDRESS | "Tezos.self" -> Some C_SELF | "Tezos.self_address" -> Some C_SELF_ADDRESS | "Tezos.implicit_account" -> Some C_IMPLICIT_ACCOUNT | "Tezos.source" -> Some C_SOURCE | "Tezos.failwith" -> Some C_FAILWITH | "Tezos.create_contract" -> Some C_CREATE_CONTRACT | "Tezos.transaction" -> Some C_CALL | "Tezos.set_delegate" -> Some C_SET_DELEGATE | "Tezos.get_contract_opt" -> Some C_CONTRACT_OPT | "Tezos.get_entrypoint_opt" -> Some C_CONTRACT_ENTRYPOINT_OPT (* Crypto module *) | "Crypto.check" -> Some C_CHECK_SIGNATURE | "Crypto.hash_key" -> Some C_HASH_KEY | "Crypto.blake2b" -> Some C_BLAKE2b | "Crypto.sha256" -> Some C_SHA256 | "Crypto.sha512" -> Some C_SHA512 (* Bytes module *) | "Bytes.pack" -> Some C_BYTES_PACK | "Bytes.unpack" -> Some C_BYTES_UNPACK | "Bytes.length" -> Some C_SIZE | "Bytes.concat" -> Some C_CONCAT | "Bytes.sub" -> Some C_SLICE (* List module *) | "List.length" -> Some C_SIZE | "List.size" -> Some C_SIZE | "List.iter" -> Some C_LIST_ITER | "List.map" -> Some C_LIST_MAP | "List.fold" -> Some C_LIST_FOLD (* Set module *) | "Set.empty" -> Some C_SET_EMPTY | "Set.literal" -> Some C_SET_LITERAL | "Set.cardinal" -> Some C_SIZE | "Set.mem" -> Some C_SET_MEM | "Set.add" -> Some C_SET_ADD | "Set.remove" -> Some C_SET_REMOVE | "Set.iter" -> Some C_SET_ITER | "Set.fold" -> Some C_SET_FOLD (* Map module *) | "Map.find_opt" -> Some C_MAP_FIND_OPT | "Map.update" -> Some C_MAP_UPDATE | "Map.iter" -> Some C_MAP_ITER | "Map.map" -> Some C_MAP_MAP | "Map.fold" -> Some C_MAP_FOLD | "Map.mem" -> Some C_MAP_MEM | "Map.size" -> Some C_SIZE | "Map.add" -> Some C_MAP_ADD | "Map.remove" -> Some C_MAP_REMOVE | "Map.empty" -> Some C_MAP_EMPTY | "Map.literal" -> Some C_MAP_LITERAL (* Big_map module *) | "Big_map.find" -> Some C_MAP_FIND | "Big_map.find_opt" -> Some C_MAP_FIND_OPT | "Big_map.update" -> Some C_MAP_UPDATE | "Big_map.literal" -> Some C_BIG_MAP_LITERAL | "Big_map.empty" -> Some C_BIG_MAP_EMPTY | "Big_map.mem" -> Some C_MAP_MEM | "Big_map.remove" -> Some C_MAP_REMOVE | "Big_map.add" -> Some C_MAP_ADD (* Bitwise module *) | "Bitwise.or" -> Some C_OR | "Bitwise.and" -> Some C_AND | "Bitwise.xor" -> Some C_XOR | "Bitwise.shift_left" -> Some C_LSL | "Bitwise.shift_right" -> Some C_LSR (* String module *) | "String.length" -> Some C_SIZE | "String.size" -> Some C_SIZE (* Deprecated *) | "String.slice" -> Some C_SLICE (* Deprecated *) | "String.sub" -> Some C_SLICE | "String.concat" -> Some C_CONCAT (* michelson pair/or type converter module *) | "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB | "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB | "Layout.convert_from_right_comb" -> Some C_CONVERT_FROM_RIGHT_COMB | "Layout.convert_from_left_comb" -> Some C_CONVERT_FROM_LEFT_COMB | _ -> None module Pascaligo = struct let constants = function (* Tezos module (ex-Michelson) *) | "chain_id" -> Some C_CHAIN_ID (* Deprecated *) | "get_chain_id" -> Some C_CHAIN_ID (* Deprecated *) | "balance" -> Some C_BALANCE (* Deprecated *) | "now" -> Some C_NOW (* Deprecated *) | "amount" -> Some C_AMOUNT (* Deprecated *) | "sender" -> Some C_SENDER (* Deprecated *) | "address" -> Some C_ADDRESS (* Deprecated *) | "self_address" -> Some C_SELF_ADDRESS (* Deprecated *) | "implicit_account" -> Some C_IMPLICIT_ACCOUNT (* Deprecated *) | "source" -> Some C_SOURCE (* Deprecated *) | "failwith" -> Some C_FAILWITH | "transaction" -> Some C_CALL (* Deprecated *) | "set_delegate" -> Some C_SET_DELEGATE (* Deprecated *) | "get_contract" -> Some C_CONTRACT (* Deprecated *) | "get_contract_opt" -> Some C_CONTRACT_OPT (* Deprecated *) | "get_entrypoint" -> Some C_CONTRACT_ENTRYPOINT (* Deprecated *) | "get_entrypoint_opt" -> Some C_CONTRACT_ENTRYPOINT_OPT (* Deprecated *) | "Michelson.is_nat" -> Some C_IS_NAT (* Deprecated *) | "is_nat" -> Some C_IS_NAT | "int" -> Some C_INT | "abs" -> Some C_ABS | "ediv" -> Some C_EDIV | "unit" -> Some C_UNIT | "NEG" -> Some C_NEG | "ADD" -> Some C_ADD | "SUB" -> Some C_SUB | "TIMES" -> Some C_MUL | "DIV" -> Some C_DIV | "MOD" -> Some C_MOD | "EQ" -> Some C_EQ | "NOT" -> Some C_NOT | "AND" -> Some C_AND | "OR" -> Some C_OR | "GT" -> Some C_GT | "GE" -> Some C_GE | "LT" -> Some C_LT | "LE" -> Some C_LE | "CONS" -> Some C_CONS | "cons" -> Some C_CONS (* Deprecated *) | "NEQ" -> Some C_NEQ (* Crypto module *) | "crypto_check" -> Some C_CHECK_SIGNATURE (* Deprecated *) | "crypto_hash_key" -> Some C_HASH_KEY (* Deprecated *) | "blake2b" -> Some C_BLAKE2b (* Deprecated *) | "sha_256" -> Some C_SHA256 (* Deprecated *) | "sha_512" -> Some C_SHA512 (* Deprecated *) (* Bytes module *) | "bytes_pack" -> Some C_BYTES_PACK (* Deprecated *) | "bytes_unpack" -> Some C_BYTES_UNPACK (* Deprecated *) | "Bytes.size" -> Some C_SIZE (* Deprecated *) | "bytes_concat" -> Some C_CONCAT (* Deprecated *) | "bytes_slice" -> Some C_SLICE (* Deprecated *) | "Bytes.slice" -> Some C_SLICE (* Deprecated *) (* List module *) | "list_size" -> Some C_SIZE (* Deprecated *) | "list_iter" -> Some C_LIST_ITER (* Deprecated *) | "list_map" -> Some C_LIST_MAP (* Deprecated *) | "list_fold" -> Some C_LIST_FOLD (* Deprecated *) (* Set module *) | "Set.size" -> Some C_SIZE (* Deprecated *) | "set_size" -> Some C_SIZE (* Deprecated *) | "set_empty" -> Some C_SET_EMPTY (* Deprecated *) | "set_mem" -> Some C_SET_MEM (* Deprecated *) | "set_add" -> Some C_SET_ADD (* Deprecated *) | "set_remove" -> Some C_SET_REMOVE (* Deprecated *) | "set_iter" -> Some C_SET_ITER (* Deprecated *) | "set_fold" -> Some C_SET_FOLD (* Deprecated *) (* Map module *) | "get_force" -> Some C_MAP_FIND (* Deprecated *) | "map_get" -> Some C_MAP_FIND_OPT (* Deprecated *) | "map_update" -> Some C_MAP_UPDATE (* Deprecated *) | "map_remove" -> Some C_MAP_REMOVE (* Deprecated *) | "map_iter" -> Some C_MAP_ITER (* Deprecated *) | "map_map" -> Some C_MAP_MAP (* Deprecated *) | "map_fold" -> Some C_MAP_FOLD (* Deprecated *) | "map_mem" -> Some C_MAP_MEM (* Deprecated *) | "map_size" -> Some C_SIZE (* Deprecated *) (* Bitwise module *) | "bitwise_or" -> Some C_OR (* Deprecated *) | "bitwise_and" -> Some C_AND (* Deprecated *) | "bitwise_xor" -> Some C_XOR (* Deprecated *) | "bitwise_lsl" -> Some C_LSL (* Deprecated *) | "bitwise_lsr" -> Some C_LSR (* Deprecated *) (* String module *) | "string_slice" -> Some C_SLICE (* Deprecated *) | "string_concat" -> Some C_CONCAT (* Deprecated *) (* Others *) | "assert" -> Some C_ASSERTION | "size" -> Some C_SIZE (* Deprecated *) | "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB | "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB | _ as c -> pseudo_modules c let type_constants = type_constants let type_operators = type_operators end module Cameligo = struct let constants = function (* Tezos (ex-Michelson, ex-Current, ex-Operation) *) | "chain_id" -> Some C_CHAIN_ID (* Deprecated *) | "Current.balance" -> Some C_BALANCE (* Deprecated *) | "balance" -> Some C_BALANCE (* Deprecated *) | "Current.time" -> Some C_NOW (* Deprecated *) | "time" -> Some C_NOW (* Deprecated *) | "Current.amount" -> Some C_AMOUNT (* Deprecated *) | "amount" -> Some C_AMOUNT (* Deprecated *) | "Current.sender" -> Some C_SENDER (* Deprecated *) | "sender" -> Some C_SENDER (* Deprecated *) | "Current.address" -> Some C_ADDRESS (* Deprecated *) | "Current.self_address" -> Some C_SELF_ADDRESS (* Deprecated *) | "Current.implicit_account" -> Some C_IMPLICIT_ACCOUNT (* Deprecated *) | "Current.source" -> Some C_SOURCE (* Deprecated *) | "source" -> Some C_SOURCE (* Deprecated *) | "Current.failwith" -> Some C_FAILWITH (* Deprecated *) | "failwith" -> Some C_FAILWITH | "Operation.transaction" -> Some C_CALL (* Deprecated *) | "Operation.set_delegate" -> Some C_SET_DELEGATE (* Deprecated *) | "Operation.get_contract" -> Some C_CONTRACT (* Deprecated *) | "Operation.get_contract_opt" -> Some C_CONTRACT_OPT (* Deprecated *) | "Operation.get_entrypoint" -> Some C_CONTRACT_ENTRYPOINT (* Deprecated *) | "Operation.get_entrypoint_opt" -> Some C_CONTRACT_ENTRYPOINT_OPT (* Deprecated *) | "Michelson.is_nat" -> Some C_IS_NAT (* Deprecated *) | "is_nat" -> Some C_IS_NAT | "int" -> Some C_INT | "abs" -> Some C_ABS | "ediv" -> Some C_EDIV | "unit" -> Some C_UNIT | "NEG" -> Some C_NEG | "ADD" -> Some C_ADD | "SUB" -> Some C_SUB | "TIMES" -> Some C_MUL | "DIV" -> Some C_DIV | "MOD" -> Some C_MOD | "EQ" -> Some C_EQ | "NOT" -> Some C_NOT | "AND" -> Some C_AND | "OR" -> Some C_OR | "GT" -> Some C_GT | "GE" -> Some C_GE | "LT" -> Some C_LT | "LE" -> Some C_LE | "CONS" -> Some C_CONS | "NEQ" -> Some C_NEQ (* Bytes module *) | "Bytes.size" -> Some C_SIZE (* Deprecated *) | "Bytes.slice" -> Some C_SLICE (* Deprecated *) (* Set module *) | "Set.size" -> Some C_SIZE (* Deprecated *) (* Map module *) | "Map.find" -> Some C_MAP_FIND (* Deprecated *) (* Bitwise module *) | "Bitwise.lor" -> Some C_OR (* Deprecated *) | "Bitwise.land" -> Some C_AND (* Deprecated *) | "Bitwise.lxor" -> Some C_XOR (* Deprecated *) (* Loop module *) | "Loop.fold_while" -> Some C_FOLD_WHILE (* Deprecated *) | "Loop.resume" -> Some C_FOLD_CONTINUE (* Deprecated *) | "continue" -> Some C_FOLD_CONTINUE (* Deprecated *) | "Loop.stop" -> Some C_FOLD_STOP (* Deprecated *) | "stop" -> Some C_FOLD_STOP (* Deprecated *) (* Others *) | "assert" -> Some C_ASSERTION | _ as c -> pseudo_modules c let type_constants = type_constants let type_operators = type_operators end end module Typer = struct module Operator_errors = struct let type_error msg expected_type actual_type () = let message () = Format.asprintf "Expected an expression of type %a but got an expression of type %a" Ast_typed.PP.type_expression expected_type Ast_typed.PP.type_expression actual_type in error (thunk msg) message open PP_helpers let print_f_args f printer ppf args = Format.fprintf ppf "%s(%a)" f (list_sep printer (const " , ")) args (* These are handled by typeclasses in the new typer *) let typeclass_error msg f expected_types actual_types () = let message () = Format.asprintf "Expected arguments with one of the following combinations of types: %a but got this combination instead: %a" (list_sep (print_f_args f Ast_typed.PP.type_expression) (const " or ")) expected_types (print_f_args f Ast_typed.PP.type_expression) actual_types in error (thunk msg) message end (* Each constant has its own type. LIGO's type-system is currently too weak to express the constant's type. For instance: - "ADD" has a special kind of type of polymorphism. If "ADD" gets two `int`s, it will return an `int`. If it gets two `nat`s, it will return a `nat`. Regular polymorphism wouldn't work because "ADD" only accepts `int`s or `nat`s. - "NONE" (from Some/None) requires an annotation. Instead of a LIGO type, constant types are representend as functions. These functions take as parameters: - The list of types of the arguments of the constants. When typing `2 + 2`, the types might be `[ int ; int ]`. - The expected type of the whole expression. It is optional. When typing `[] : list(operation)`, it will be `Some ( list (operation) )`. When typing `2 + 2` (with no additional context), it will be `None`. The output is the type of the whole expression. An error is returned through the Trace monad if it doesn't type-check (`"toto" + 42`). Various helpers are defined and explaines in `Helpers.Typer`. *) open Helpers.Typer open Ast_typed module Converter = Converter module Operators_types = struct open Typesystem.Shorthands let tc_subarg a b c = tc "arguments for (-)" [a;b;c] [ (*TODO…*) ] let tc_sizearg a = tc "arguments for size" [a] [ [int] ] let tc_packable a = tc "packable" [a] [ [int] ; [string] ; [bool] (*TODO…*) ] let tc_timargs a b c = tc "arguments for ( * )" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] let tc_edivargs a b c = tc "arguments for ediv" [a;b;c] [ (*TODO…*) ] let tc_divargs a b c = tc "arguments for div" [a;b;c] [ (*TODO…*) ] let tc_modargs a b c = tc "arguments for mod" [a;b;c] [ (*TODO…*) ] let tc_addargs a b c = tc "arguments for (+)" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] let tc_comparable a = tc "comparable" [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ] let tc_concatable a = tc "concatenable" [a] [ [string] ; [bytes] ] let tc_storable a = tc "storable" [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ] let t_none = forall "a" @@ fun a -> option a let t_sub = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_subarg a b c] => tuple2 a b --> c (* TYPECLASS *) let t_some = forall "a" @@ fun a -> a --> option a let t_map_remove = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> map src dst let t_map_add = forall2 "src" "dst" @@ fun src dst -> tuple3 src dst (map src dst) --> map src dst let t_map_update = forall2 "src" "dst" @@ fun src dst -> tuple3 src (option dst) (map src dst) --> map src dst let t_map_mem = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> bool let t_map_find = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst let t_map_find_opt = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> option dst let t_map_fold = forall3 "src" "dst" "acc" @@ fun src dst acc -> tuple3 ( ( (src * dst) * acc ) --> acc ) (map src dst) acc --> acc let t_map_map = forall3 "k" "v" "result" @@ fun k v result -> tuple2 ((k * v) --> result) (map k v) --> map k result (* TODO: the type of map_map_fold might be wrong, check it. *) let t_map_map_fold = forall4 "k" "v" "acc" "dst" @@ fun k v acc dst -> tuple3 ( ((k * v) * acc) --> acc * dst ) (map k v) (k * v) --> (map k dst * acc) let t_map_iter = forall2 "k" "v" @@ fun k v -> tuple2 ( (k * v) --> unit ) (map k v) --> unit let t_size = forall_tc "c" @@ fun c -> [tc_sizearg c] => tuple1 c --> nat (* TYPECLASS *) let t_slice = tuple3 nat nat string --> string let t_failwith = tuple1 string --> unit let t_get_force = forall2 "src" "dst" @@ fun src dst -> tuple2 src (map src dst) --> dst let t_int = tuple1 nat --> int let t_bytes_pack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 a --> bytes (* TYPECLASS *) let t_bytes_unpack = forall_tc "a" @@ fun a -> [tc_packable a] => tuple1 bytes --> a (* TYPECLASS *) let t_hash256 = tuple1 bytes --> bytes let t_hash512 = tuple1 bytes --> bytes let t_blake2b = tuple1 bytes --> bytes let t_hash_key = tuple1 key --> key_hash let t_is_nat = tuple1 int --> bool let t_check_signature = tuple3 key signature bytes --> bool let t_chain_id = tuple0 --> chain_id let t_sender = tuple0 --> address let t_source = tuple0 --> address let t_unit = tuple0 --> unit let t_amount = tuple0 --> mutez let t_balance = tuple0 --> mutez let t_address = tuple0 --> address let t_now = tuple0 --> timestamp let t_transaction = forall "a" @@ fun a -> tuple3 a mutez (contract a) --> operation let t_get_contract = forall "a" @@ fun a -> tuple0 --> contract a let t_abs = tuple1 int --> nat let t_cons = forall "a" @@ fun a -> tuple2 a (list a) --> list a let t_assertion = tuple1 bool --> unit let t_times = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_timargs a b c] => tuple2 a b --> c (* TYPECLASS *) let t_ediv = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_edivargs a b c] => tuple2 a b --> c (* TYPECLASS *) let t_div = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_divargs a b c] => tuple2 a b --> c (* TYPECLASS *) let t_mod = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_modargs a b c] => tuple2 a b --> c (* TYPECLASS *) let t_add = forall3_tc "a" "b" "c" @@ fun a b c -> [tc_addargs a b c] => tuple2 a b --> c (* TYPECLASS *) let t_set_mem = forall "a" @@ fun a -> tuple2 a (set a) --> bool let t_set_add = forall "a" @@ fun a -> tuple2 a (set a) --> set a let t_set_remove = forall "a" @@ fun a -> tuple2 a (set a) --> set a let t_not = tuple1 bool --> bool let t_continuation = forall "a" @@ fun a -> tuple2 bool a --> pair bool a let t_fold_while = forall "a" @@ fun a -> tuple2 (a --> pair bool a) a --> a let t_neg = tuple1 int --> int let t_and = tuple2 bool bool --> bool let t_or = tuple2 bool bool --> bool let t_xor = tuple2 bool bool --> bool let t_lsl = tuple2 nat nat --> nat let t_lsr = tuple2 nat nat --> nat let t_comp = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 a a --> bool let t_concat = forall_tc "a" @@ fun a -> [tc_concatable a] => tuple2 a a --> a let t_set_empty = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple0 --> set a let t_set_iter = forall_tc "a" @@ fun a -> [tc_comparable a] => tuple2 (a --> unit) (set a) --> unit (* TODO: check that the implementation has this type *) let t_set_fold = forall2_tc "a" "b" @@ fun a b -> [tc_comparable b] => tuple3 (pair a b --> a) (set b) a --> a let t_list_iter = forall "a" @@ fun a -> tuple2 (a --> unit) (list a) --> unit let t_list_map = forall "a" @@ fun a -> tuple2 (a --> a) (list a) --> (list a) (* TODO: check that the implementation has this type *) let t_list_fold = forall2 "a" "b" @@ fun a b -> tuple3 (pair a b --> a) (list b) a --> a let t_self_address = tuple0 --> address let t_implicit_account = forall_tc "a" @@ fun a -> [tc_storable a] => tuple1 key_hash --> contract a let t_set_delegate = tuple1 (option key_hash) --> operation let constant_type : constant' -> Typesystem.Core.type_value result = function | C_INT -> ok @@ t_int ; | C_UNIT -> ok @@ t_unit ; | C_NOW -> ok @@ t_now ; | C_IS_NAT -> ok @@ t_is_nat ; | C_SOME -> ok @@ t_some ; | C_NONE -> ok @@ t_none ; | C_ASSERTION -> ok @@ t_assertion ; | C_FAILWITH -> ok @@ t_failwith ; (* LOOPS *) | C_FOLD_WHILE -> ok @@ t_fold_while ; | C_FOLD_CONTINUE -> ok @@ t_continuation ; | C_FOLD_STOP -> ok @@ t_continuation ; (* MATH *) | C_NEG -> ok @@ t_neg ; | C_ABS -> ok @@ t_abs ; | C_ADD -> ok @@ t_add ; | C_SUB -> ok @@ t_sub ; | C_MUL -> ok @@ t_times ; | C_EDIV -> ok @@ t_ediv ; | C_DIV -> ok @@ t_div ; | C_MOD -> ok @@ t_mod ; (* LOGIC *) | C_NOT -> ok @@ t_not ; | C_AND -> ok @@ t_and ; | C_OR -> ok @@ t_or ; | C_XOR -> ok @@ t_xor ; | C_LSL -> ok @@ t_lsl ; | C_LSR -> ok @@ t_lsr ; (* COMPARATOR *) | C_EQ -> ok @@ t_comp ; | C_NEQ -> ok @@ t_comp ; | C_LT -> ok @@ t_comp ; | C_GT -> ok @@ t_comp ; | C_LE -> ok @@ t_comp ; | C_GE -> ok @@ t_comp ; (* BYTES / STRING *) | C_SIZE -> ok @@ t_size ; | C_CONCAT -> ok @@ t_concat ; | C_SLICE -> ok @@ t_slice ; | C_BYTES_PACK -> ok @@ t_bytes_pack ; | C_BYTES_UNPACK -> ok @@ t_bytes_unpack ; | C_CONS -> ok @@ t_cons ; (* SET *) | C_SET_EMPTY -> ok @@ t_set_empty ; | C_SET_ADD -> ok @@ t_set_add ; | C_SET_REMOVE -> ok @@ t_set_remove ; | C_SET_ITER -> ok @@ t_set_iter ; | C_SET_FOLD -> ok @@ t_set_fold ; | C_SET_MEM -> ok @@ t_set_mem ; (* LIST *) | C_LIST_ITER -> ok @@ t_list_iter ; | C_LIST_MAP -> ok @@ t_list_map ; | C_LIST_FOLD -> ok @@ t_list_fold ; (* MAP *) | C_MAP_ADD -> ok @@ t_map_add ; | C_MAP_REMOVE -> ok @@ t_map_remove ; | C_MAP_UPDATE -> ok @@ t_map_update ; | C_MAP_ITER -> ok @@ t_map_iter ; | C_MAP_MAP -> ok @@ t_map_map ; | C_MAP_FOLD -> ok @@ t_map_fold ; | C_MAP_MEM -> ok @@ t_map_mem ; | C_MAP_FIND -> ok @@ t_map_find ; | C_MAP_FIND_OPT -> ok @@ t_map_find_opt ; (* BIG MAP *) (* CRYPTO *) | C_SHA256 -> ok @@ t_hash256 ; | C_SHA512 -> ok @@ t_hash512 ; | C_BLAKE2b -> ok @@ t_blake2b ; | C_HASH_KEY -> ok @@ t_hash_key ; | C_CHECK_SIGNATURE -> ok @@ t_check_signature ; | C_CHAIN_ID -> ok @@ t_chain_id ; (*BLOCKCHAIN *) | C_CONTRACT -> ok @@ t_get_contract ; | C_CONTRACT_ENTRYPOINT -> ok @@ failwith "t_get_entrypoint" ; | C_AMOUNT -> ok @@ t_amount ; | C_BALANCE -> ok @@ t_balance ; | C_CALL -> ok @@ t_transaction ; | C_SENDER -> ok @@ t_sender ; | C_SOURCE -> ok @@ t_source ; | C_ADDRESS -> ok @@ t_address ; | C_SELF_ADDRESS -> ok @@ t_self_address; | C_IMPLICIT_ACCOUNT -> ok @@ t_implicit_account; | C_SET_DELEGATE -> ok @@ t_set_delegate ; | c -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" Ast_typed.PP.constant c end let none = typer_0 "NONE" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped NONE" | Some t -> ok t let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped SET_EMPTY" | Some t -> ok t let sub = typer_2 "SUB" @@ fun a b -> if (eq_1 a (t_int ()) || eq_1 a (t_nat ())) && (eq_1 b (t_int ()) || eq_1 b (t_nat ())) then ok @@ t_int () else if (eq_2 (a , b) (t_timestamp ())) then ok @@ t_int () else if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) then ok @@ t_timestamp () else if (eq_2 (a , b) (t_mutez ())) then ok @@ t_mutez () else fail (simple_error "Typing substraction, bad parameters.") let some = typer_1 "SOME" @@ fun a -> ok @@ t_option a () let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m -> let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src , k) in ok m let map_empty = typer_0 "MAP_EMPTY" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped MAP_EMPTY" | Some t -> let%bind (src, dst) = get_t_map t in ok @@ t_map src dst () let big_map_empty = typer_0 "BIG_MAP_EMPTY" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped BIG_MAP_EMPTY" | Some t -> let%bind (src, dst) = get_t_big_map t in ok @@ t_big_map src dst () let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in let%bind () = assert_type_expression_eq (dst, v) in ok m let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in let%bind v' = get_t_option v in let%bind () = assert_type_expression_eq (dst, v') in ok m let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m -> let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in ok @@ t_bool () let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> let%bind (src, dst) = trace_strong (simple_error "MAP_FIND: not map or bigmap") @@ bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in ok @@ dst let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m -> let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_expression_eq (src, k) in ok @@ t_option dst () let map_iter : typer = typer_2 "MAP_ITER" @@ fun f m -> let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () let map_map : typer = typer_2 "MAP_MAP" @@ fun f m -> let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in ok @@ t_nat () let slice = typer_3 "SLICE" @@ fun i j s -> let%bind () = assert_eq_1 i (t_nat ()) in let%bind () = assert_eq_1 j (t_nat ()) in if eq_1 s (t_string ()) then ok @@ t_string () else if eq_1 s (t_bytes ()) then ok @@ t_bytes () else fail @@ Operator_errors.typeclass_error "Computing slice with wrong types" "slice" [ [t_nat();t_nat();t_string()] ; [t_nat();t_nat();t_bytes()] ; ] [i ; j ; s] () let failwith_ = typer_1_opt "FAILWITH" @@ fun t opt -> let%bind _ = if eq_1 t (t_string ()) then ok () else if eq_1 t (t_nat ()) then ok () else if eq_1 t (t_int ()) then ok () else fail @@ Operator_errors.typeclass_error "Failwith with disallowed type" "failwith" [ [t_string()] ; [t_nat()] ; [t_int()] ; ] [t] () in let default = t_unit () in ok @@ Simple_utils.Option.unopt ~default opt let int : typer = typer_1 "INT" @@ fun t -> let%bind () = assert_t_nat t in ok @@ t_int () let bytes_pack : typer = typer_1 "PACK" @@ fun _t -> ok @@ t_bytes () let bytes_unpack = typer_1_opt "UNPACK" @@ fun input output_opt -> let%bind () = assert_t_bytes input in trace_option (simple_error "untyped UNPACK") @@ output_opt 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 () let unit = constant' "UNIT" @@ t_unit () let amount = constant' "AMOUNT" @@ t_mutez () let balance = constant' "BALANCE" @@ t_mutez () let chain_id = constant' "CHAIN_ID" @@ t_chain_id () let address = typer_1 "ADDRESS" @@ fun contract -> let%bind () = assert_t_contract contract in ok @@ t_address () let self_address = typer_0 "SELF_ADDRESS" @@ fun _ -> ok @@ t_address () let self = typer_1_opt "SELF" @@ fun entrypoint_as_string tv_opt -> let%bind () = assert_t_string entrypoint_as_string in match tv_opt with | None -> simple_fail "untyped SELF" | Some t -> ok @@ t let implicit_account = typer_1 "IMPLICIT_ACCOUNT" @@ fun key_hash -> let%bind () = assert_t_key_hash key_hash in ok @@ t_contract (t_unit () ) () let now = constant' "NOW" @@ t_timestamp () let transaction = typer_3 "CALL" @@ fun param amount contract -> let%bind () = assert_t_mutez amount in let%bind contract_param = get_t_contract contract in let%bind () = assert_type_expression_eq (param , contract_param) in ok @@ t_operation () let create_contract = typer_4 "CREATE_CONTRACT" @@ fun f kh_opt amount init_storage -> let%bind (args , ret) = get_t_function f in let%bind (_,s) = get_t_pair args in let%bind (oplist,s') = get_t_pair ret in let%bind () = assert_t_mutez amount in let%bind (delegate) = get_t_option kh_opt in let%bind () = assert_type_expression_eq (s,s') in let%bind () = assert_type_expression_eq (s,init_storage) in let%bind () = assert_t_list_operation oplist in let%bind () = assert_t_key_hash delegate in ok @@ t_pair (t_operation ()) (t_address ()) () let get_contract = typer_1_opt "CONTRACT" @@ fun addr_tv tv_opt -> if not (type_expression_eq (addr_tv, t_address ())) then fail @@ simple_error (Format.asprintf "get_contract expects an address, got %a" PP.type_expression addr_tv) else let%bind tv = trace_option (simple_error "get_contract needs a type annotation") tv_opt in let%bind tv' = trace_strong (simple_error "get_contract has a not-contract annotation") @@ get_t_contract tv in ok @@ t_contract tv' () let get_contract_opt = typer_1_opt "CONTRACT OPT" @@ fun addr_tv tv_opt -> if not (type_expression_eq (addr_tv, t_address ())) then fail @@ simple_error (Format.asprintf "get_contract_opt expects an address, got %a" PP.type_expression addr_tv) else let%bind tv = trace_option (simple_error "get_contract_opt needs a type annotation") tv_opt in let%bind tv = trace_strong (simple_error "get_entrypoint_opt has a not-option annotation") @@ get_t_option tv in let%bind tv' = trace_strong (simple_error "get_entrypoint_opt has a not-option(contract) annotation") @@ get_t_contract tv in ok @@ t_option (t_contract tv' ()) () let get_entrypoint = typer_2_opt "CONTRACT_ENTRYPOINT" @@ fun entry_tv addr_tv tv_opt -> if not (type_expression_eq (entry_tv, t_string ())) then fail @@ simple_error (Format.asprintf "get_entrypoint expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv) else if not (type_expression_eq (addr_tv, t_address ())) then fail @@ simple_error (Format.asprintf "get_entrypoint expects an address for second argument, got %a" PP.type_expression addr_tv) else let%bind tv = trace_option (simple_error "get_entrypoint needs a type annotation") tv_opt in let%bind tv' = trace_strong (simple_error "get_entrypoint has a not-contract annotation") @@ get_t_contract tv in ok @@ t_contract tv' () let get_entrypoint_opt = typer_2_opt "CONTRACT_ENTRYPOINT_OPT" @@ fun entry_tv addr_tv tv_opt -> if not (type_expression_eq (entry_tv, t_string ())) then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects a string entrypoint label for first argument, got %a" PP.type_expression entry_tv) else if not (type_expression_eq (addr_tv, t_address ())) then fail @@ simple_error (Format.asprintf "get_entrypoint_opt expects an address for second argument, got %a" PP.type_expression addr_tv) else let%bind tv = trace_option (simple_error "get_entrypoint_opt needs a type annotation") tv_opt in let%bind tv = trace_strong (simple_error "get_entrypoint_opt has a not-option annotation") @@ get_t_option tv in let%bind tv' = trace_strong (simple_error "get_entrypoint_opt has a not-option(contract) annotation") @@ get_t_contract tv in ok @@ t_option (t_contract tv' ())() let set_delegate = typer_1 "SET_DELEGATE" @@ fun delegate_opt -> let%bind () = assert_eq_1 delegate_opt (t_option (t_key_hash ()) ()) in ok @@ t_operation () let abs = typer_1 "ABS" @@ fun t -> let%bind () = assert_t_int t in ok @@ t_nat () let is_nat = typer_1 "ISNAT" @@ fun t -> let%bind () = assert_t_int t in ok @@ t_option (t_nat ()) () let neg = typer_1 "NEG" @@ fun t -> let%bind () = Assert.assert_true (eq_1 t (t_nat ()) || eq_1 t (t_int ())) in ok @@ t_int () let assertion = typer_1 "ASSERT" @@ fun a -> if eq_1 a (t_bool ()) then ok @@ t_unit () else fail @@ Operator_errors.type_error "Asserting a non-bool" a (t_bool ()) () let times = typer_2 "TIMES" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else if (eq_1 a (t_nat ()) && eq_1 b (t_mutez ())) || (eq_1 b (t_nat ()) && eq_1 a (t_mutez ())) then ok @@ t_mutez () else fail @@ Operator_errors.typeclass_error "Multiplying with wrong types" "multiply" [ [t_nat();t_nat()] ; [t_int();t_int()] ; [t_nat();t_mutez()] ; [t_mutez();t_nat()] ; ] [a; b] () let ediv = typer_2 "EDIV" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_option (t_pair (t_nat ()) (t_nat ()) ()) () else if eq_2 (a , b) (t_int ()) then ok @@ t_option (t_pair (t_int ()) (t_nat ()) ()) () else if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ()) then ok @@ t_option (t_pair (t_nat ()) (t_mutez ()) ()) () else if eq_1 a (t_mutez ()) && eq_1 b (t_nat ()) then ok @@ t_option (t_pair (t_mutez ()) (t_mutez ()) ()) () else fail @@ Operator_errors.typeclass_error "Dividing with wrong types" "divide" [ [t_nat();t_nat()] ; [t_int();t_int()] ; [t_mutez();t_nat()] ; [t_mutez();t_mutez()] ; ] [a; b] () let div = typer_2 "DIV" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else if eq_1 a (t_mutez ()) && eq_1 b (t_nat ()) then ok @@ t_mutez () else if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ()) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "Dividing with wrong types" "divide" [ [t_nat();t_nat()] ; [t_int();t_int()] ; [t_mutez();t_nat()] ; [t_mutez();t_mutez()] ; ] [a; b] () let mod_ = typer_2 "MOD" @@ fun a b -> if (eq_1 a (t_nat ()) || eq_1 a (t_int ())) && (eq_1 b (t_nat ()) || eq_1 b (t_int ())) then ok @@ t_nat () else if eq_1 a (t_mutez ()) && eq_1 b (t_mutez ()) then ok @@ t_mutez () else fail @@ Operator_errors.typeclass_error "Computing modulo with wrong types" "modulo" [ [t_nat();t_nat()] ; [t_nat();t_int()] ; [t_int();t_nat()] ; [t_int();t_int()] ; [t_mutez();t_mutez()] ; ] [a; b] () let add = typer_2 "ADD" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else if eq_2 (a , b) (t_int ()) then ok @@ t_int () else if eq_2 (a , b) (t_mutez ()) then ok @@ t_mutez () else if (eq_1 a (t_nat ()) && eq_1 b (t_int ())) || (eq_1 b (t_nat ()) && eq_1 a (t_int ())) then ok @@ t_int () else if (eq_1 a (t_timestamp ()) && eq_1 b (t_int ())) || (eq_1 b (t_timestamp ()) && eq_1 a (t_int ())) then ok @@ t_timestamp () else fail @@ Operator_errors.typeclass_error "Adding modulo with wrong types" "add" [ [t_nat();t_nat()] ; [t_int();t_int()] ; [t_mutez();t_mutez()] ; [t_nat();t_int()] ; [t_int();t_nat()] ; [t_timestamp();t_int()] ; [t_int();t_timestamp()] ; ] [a; b] () let set_mem = typer_2 "SET_MEM" @@ fun elt set -> let%bind key = get_t_set set in if eq_1 elt key then ok @@ t_bool () else fail @@ Operator_errors.type_error "Set.mem: elt and set don't match" elt key () let set_add = typer_2 "SET_ADD" @@ fun elt set -> let%bind key = get_t_set set in if eq_1 elt key then ok set else fail @@ Operator_errors.type_error "Set.add: elt and set don't match" elt key () let set_remove = typer_2 "SET_REMOVE" @@ fun elt set -> let%bind key = get_t_set set in if eq_1 elt key then ok set else fail @@ Operator_errors.type_error "Set.remove: elt and set don't match" key elt () let set_iter = typer_2 "SET_ITER" @@ fun body set -> let%bind (arg , res) = get_t_function body in let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in let%bind key = get_t_set set in if eq_1 key arg then ok (t_unit ()) else fail @@ Operator_errors.type_error "bad set iter" key arg () let list_empty = typer_0 "LIST_EMPTY" @@ fun tv_opt -> match tv_opt with | None -> simple_fail "untyped LIST_EMPTY" | Some t -> ok t let list_iter = typer_2 "LIST_ITER" @@ fun body lst -> let%bind (arg , res) = get_t_function body in let%bind () = Assert.assert_true (eq_1 res (t_unit ())) in let%bind key = get_t_list lst in if eq_1 key arg then ok (t_unit ()) else fail @@ Operator_errors.type_error "bad list iter" key arg () let list_map = typer_2 "LIST_MAP" @@ fun body lst -> let%bind (arg , res) = get_t_function body in let%bind key = get_t_list lst in if eq_1 key arg then ok (t_list res ()) else fail @@ Operator_errors.type_error "bad list map" key arg () let list_fold = typer_3 "LIST_FOLD" @@ fun body lst init -> let%bind (arg , res) = get_t_function body in let%bind (prec , cur) = get_t_pair arg in let%bind key = get_t_list lst in let msg = Format.asprintf "%a vs %a" PP.type_expression key PP.type_expression arg in trace (simple_error ("bad list fold:" ^ msg)) @@ let%bind () = assert_eq_1 ~msg:"key cur" key cur in let%bind () = assert_eq_1 ~msg:"prec res" prec res in let%bind () = assert_eq_1 ~msg:"res init" res init in ok res let set_fold = typer_3 "SET_FOLD" @@ fun body lst init -> let%bind (arg , res) = get_t_function body in let%bind (prec , cur) = get_t_pair arg in let%bind key = get_t_set lst in let msg = Format.asprintf "%a vs %a" PP.type_expression key PP.type_expression arg in trace (simple_error ("bad set fold:" ^ msg)) @@ let%bind () = assert_eq_1 ~msg:"key cur" key cur in let%bind () = assert_eq_1 ~msg:"prec res" prec res in let%bind () = assert_eq_1 ~msg:"res init" res init in ok res let map_fold = typer_3 "MAP_FOLD" @@ fun body map init -> let%bind (arg , res) = get_t_function body in let%bind (prec , cur) = get_t_pair arg in let%bind (key , value) = get_t_map map in let msg = Format.asprintf "%a vs %a" PP.type_expression key PP.type_expression arg in trace (simple_error ("bad map fold:" ^ msg)) @@ let%bind () = assert_eq_1 ~msg:"key cur" (t_pair key value ()) cur in let%bind () = assert_eq_1 ~msg:"prec res" prec res in let%bind () = assert_eq_1 ~msg:"res init" res init in ok res (** FOLD_WHILE is a fold operation that takes an initial value of a certain type and then iterates on it until a condition is reached. The auxillary function that does the fold returns either boolean true or boolean false to indicate whether the fold should continue or not. Necessarily then the initial value must match the input parameter of the auxillary function, and the auxillary should return type (bool * input) *) let fold_while = typer_2 "FOLD_WHILE" @@ fun body init -> let%bind (arg, result) = get_t_function body in let%bind () = assert_eq_1 arg init in let%bind () = assert_eq_1 (t_pair (t_bool ()) init ()) result in ok init (* Continue and Stop are just syntactic sugar for building a pair (bool * a') *) let continue = typer_1 "CONTINUE" @@ fun arg -> ok @@ t_pair (t_bool ()) arg () let stop = typer_1 "STOP" @@ fun arg -> ok (t_pair (t_bool ()) arg ()) let not_ = typer_1 "NOT" @@ fun elt -> if eq_1 elt (t_bool ()) then ok @@ t_bool () else if eq_1 elt (t_nat ()) || eq_1 elt (t_int ()) then ok @@ t_int () else fail @@ Operator_errors.type_error "bad parameter to not" elt (t_bool ()) () let or_ = typer_2 "OR" @@ fun a b -> if eq_2 (a , b) (t_bool ()) then ok @@ t_bool () else if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "OR with wrong types" "or" [ [t_bool();t_bool()] ; [t_nat();t_nat()] ; ] [a; b] () let xor = typer_2 "XOR" @@ fun a b -> if eq_2 (a , b) (t_bool ()) then ok @@ t_bool () else if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "XOR with wrong types" "xor" [ [t_bool();t_bool()] ; [t_nat();t_nat()] ; ] [a; b] () let and_ = typer_2 "AND" @@ fun a b -> if eq_2 (a , b) (t_bool ()) then ok @@ t_bool () else if eq_2 (a , b) (t_nat ()) || (eq_1 b (t_nat ()) && eq_1 a (t_int ())) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "AND with wrong types" "and" [ [t_bool();t_bool()] ; [t_nat();t_nat()] ; [t_int();t_nat()] ; ] [a; b] () let lsl_ = typer_2 "LSL" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "LSL with wrong types" "lsl" [ [t_nat();t_nat()] ; ] [a; b] () let lsr_ = typer_2 "LSR" @@ fun a b -> if eq_2 (a , b) (t_nat ()) then ok @@ t_nat () else fail @@ Operator_errors.typeclass_error "LSR with wrong types" "lsr" [ [t_nat();t_nat()] ; ] [a; b] () let concat = typer_2 "CONCAT" @@ fun a b -> if eq_2 (a , b) (t_string ()) then ok @@ t_string () else if eq_2 (a , b) (t_bytes ()) then ok @@ t_bytes () else fail @@ Operator_errors.typeclass_error "Concatenation with wrong types" "concat" [ [t_string();t_string()] ; [t_bytes();t_bytes()] ; ] [a; b] () let cons = typer_2 "CONS" @@ fun hd tl -> let%bind elt = get_t_list tl in let%bind () = assert_eq_1 hd elt in ok tl let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun t -> match t.type_content with | T_record lmap -> let kvl = LMap.to_kv_list lmap in let%bind () = Converter.record_checks kvl in let pair = Converter.convert_pair_to_right_comb kvl in ok {t with type_content = pair} | T_sum cmap -> let kvl = CMap.to_kv_list cmap in let%bind () = Converter.variant_checks kvl in let michelson_or = Converter.convert_variant_to_right_comb kvl in ok {t with type_content = michelson_or} | _ -> simple_fail "converter can only be used on record or variants" let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun t -> match t.type_content with | T_record lmap -> let kvl = LMap.to_kv_list lmap in let%bind () = Converter.record_checks kvl in let pair = Converter.convert_pair_to_left_comb kvl in ok {t with type_content = pair} | T_sum cmap -> let kvl = CMap.to_kv_list cmap in let%bind () = Converter.variant_checks kvl in let michelson_or = Converter.convert_variant_to_left_comb kvl in ok {t with type_content = michelson_or} | _ -> simple_fail "converter can only be used on record or variants" let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun t opt -> match t.type_content with | T_record src_lmap -> let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in let%bind dst_lmap = get_t_record dst_t in let%bind record = Converter.convert_pair_from_right_comb src_lmap dst_lmap in ok {t with type_content = record} | T_sum src_cmap -> let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in let%bind dst_cmap = get_t_sum dst_t in let%bind variant = Converter.convert_variant_from_right_comb src_cmap dst_cmap in ok {t with type_content = variant} | _ -> simple_fail "converter can only be used on record or variants" let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun t opt -> match t.type_content with | T_record src_lmap -> let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in let%bind dst_lmap = get_t_record dst_t in let%bind record = Converter.convert_pair_from_left_comb src_lmap dst_lmap in ok {t with type_content = record} | T_sum src_cmap -> let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in let%bind dst_cmap = get_t_sum dst_t in let%bind variant = Converter.convert_variant_from_left_comb src_cmap dst_cmap in ok {t with type_content = variant} | _ -> simple_fail "converter can only be used on record or variants" let constant_typers c : typer result = match c with | C_INT -> ok @@ int ; | C_UNIT -> ok @@ unit ; | C_NOW -> ok @@ now ; | C_IS_NAT -> ok @@ is_nat ; | C_SOME -> ok @@ some ; | C_NONE -> ok @@ none ; | C_ASSERTION -> ok @@ assertion ; | C_FAILWITH -> ok @@ failwith_ ; (* LOOPS *) | C_FOLD_WHILE -> ok @@ fold_while ; | C_FOLD_CONTINUE -> ok @@ continue ; | C_FOLD_STOP -> ok @@ stop ; (* MATH *) | C_NEG -> ok @@ neg ; | C_ABS -> ok @@ abs ; | C_ADD -> ok @@ add ; | C_SUB -> ok @@ sub ; | C_MUL -> ok @@ times ; | C_EDIV -> ok @@ ediv ; | C_DIV -> ok @@ div ; | C_MOD -> ok @@ mod_ ; (* LOGIC *) | C_NOT -> ok @@ not_ ; | C_AND -> ok @@ and_ ; | C_OR -> ok @@ or_ ; | C_XOR -> ok @@ xor ; | C_LSL -> ok @@ lsl_; | C_LSR -> ok @@ lsr_; (* COMPARATOR *) | C_EQ -> ok @@ comparator "EQ" ; | C_NEQ -> ok @@ comparator "NEQ" ; | C_LT -> ok @@ comparator "LT" ; | C_GT -> ok @@ comparator "GT" ; | C_LE -> ok @@ comparator "LE" ; | C_GE -> ok @@ comparator "GE" ; (* BYTES / STRING *) | C_SIZE -> ok @@ size ; | C_CONCAT -> ok @@ concat ; | C_SLICE -> ok @@ slice ; | C_BYTES_PACK -> ok @@ bytes_pack ; | C_BYTES_UNPACK -> ok @@ bytes_unpack ; (* SET *) | C_SET_EMPTY -> ok @@ set_empty ; | C_SET_ADD -> ok @@ set_add ; | C_SET_REMOVE -> ok @@ set_remove ; | C_SET_ITER -> ok @@ set_iter ; | C_SET_FOLD -> ok @@ set_fold ; | C_SET_MEM -> ok @@ set_mem ; (* LIST *) | C_CONS -> ok @@ cons ; | C_LIST_EMPTY -> ok @@ list_empty ; | C_LIST_ITER -> ok @@ list_iter ; | C_LIST_MAP -> ok @@ list_map ; | C_LIST_FOLD -> ok @@ list_fold ; (* MAP *) | C_MAP_EMPTY -> ok @@ map_empty ; | C_BIG_MAP_EMPTY -> ok @@ big_map_empty ; | C_MAP_ADD -> ok @@ map_add ; | C_MAP_REMOVE -> ok @@ map_remove ; | C_MAP_UPDATE -> ok @@ map_update ; | C_MAP_ITER -> ok @@ map_iter ; | C_MAP_MAP -> ok @@ map_map ; | C_MAP_FOLD -> ok @@ map_fold ; | C_MAP_MEM -> ok @@ map_mem ; | C_MAP_FIND -> ok @@ map_find ; | C_MAP_FIND_OPT -> ok @@ map_find_opt ; (* BIG MAP *) (* CRYPTO *) | C_SHA256 -> ok @@ hash256 ; | C_SHA512 -> ok @@ hash512 ; | C_BLAKE2b -> ok @@ blake2b ; | C_HASH_KEY -> ok @@ hash_key ; | C_CHECK_SIGNATURE -> ok @@ check_signature ; | C_CHAIN_ID -> ok @@ chain_id ; (*BLOCKCHAIN *) | C_CONTRACT -> ok @@ get_contract ; | C_CONTRACT_OPT -> ok @@ get_contract_opt ; | C_CONTRACT_ENTRYPOINT -> ok @@ get_entrypoint ; | C_CONTRACT_ENTRYPOINT_OPT -> ok @@ get_entrypoint_opt ; | C_AMOUNT -> ok @@ amount ; | C_BALANCE -> ok @@ balance ; | C_CALL -> ok @@ transaction ; | C_SENDER -> ok @@ sender ; | C_SOURCE -> ok @@ source ; | C_ADDRESS -> ok @@ address ; | C_SELF -> ok @@ self; | C_SELF_ADDRESS -> ok @@ self_address; | C_IMPLICIT_ACCOUNT -> ok @@ implicit_account; | C_SET_DELEGATE -> ok @@ set_delegate ; | C_CREATE_CONTRACT -> ok @@ create_contract ; | C_CONVERT_TO_RIGHT_COMB -> ok @@ convert_to_right_comb ; | C_CONVERT_TO_LEFT_COMB -> ok @@ convert_to_left_comb ; | C_CONVERT_FROM_RIGHT_COMB -> ok @@ convert_from_right_comb ; | C_CONVERT_FROM_LEFT_COMB -> ok @@ convert_from_left_comb ; | _ -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" PP.constant c end module Compiler = struct (* Most constants pass through the Transpiler unchanged. So they need to be compiled down to Michelson. This is the last step. When compiling the constant, we need to provide its arity (through the type predicate, defined in `Helpers.Compiler`, and its michelson code. In the case of an n-ary constant, we assume that the stack has the form: `x1 :: x2 :: x3 ... :: xn :: _`. This step requires knowledge of Michelson. Knowledge of `Tezos_utils.Michelson` will help too, so that no Michelson has to actually be written by hand. *) include Helpers.Compiler open Tezos_utils.Michelson open Mini_c let get_operators c : predicate result = match c with | C_ADD -> ok @@ simple_binary @@ prim I_ADD | C_SUB -> ok @@ simple_binary @@ prim I_SUB | C_MUL -> ok @@ simple_binary @@ prim I_MUL | C_EDIV -> ok @@ simple_binary @@ prim I_EDIV | C_DIV -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "DIV by 0") ; i_car] | C_MOD -> ok @@ simple_binary @@ seq [prim I_EDIV ; i_assert_some_msg (i_push_string "MOD by 0") ; i_cdr] | C_NEG -> ok @@ simple_unary @@ prim I_NEG | C_OR -> ok @@ simple_binary @@ prim I_OR | C_AND -> ok @@ simple_binary @@ prim I_AND | C_XOR -> ok @@ simple_binary @@ prim I_XOR | C_LSL -> ok @@ simple_binary @@ prim I_LSL | C_LSR -> ok @@ simple_binary @@ prim I_LSR | C_NOT -> ok @@ simple_unary @@ prim I_NOT | C_PAIR -> ok @@ simple_binary @@ prim I_PAIR | C_CAR -> ok @@ simple_unary @@ prim I_CAR | C_CDR -> ok @@ simple_unary @@ prim I_CDR | C_EQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_EQ] | C_NEQ -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_NEQ] | C_LT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LT] | C_LE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_LE] | C_GT -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GT] | C_GE -> ok @@ simple_binary @@ seq [prim I_COMPARE ; prim I_GE] | C_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE | C_SOME -> ok @@ simple_unary @@ prim I_SOME | C_MAP_FIND -> ok @@ simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")] | C_MAP_MEM -> ok @@ simple_binary @@ prim I_MEM | C_MAP_FIND_OPT -> ok @@ simple_binary @@ prim I_GET | C_MAP_ADD -> ok @@ simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE] | C_MAP_UPDATE -> ok @@ simple_ternary @@ prim I_UPDATE | C_FOLD_WHILE -> ok @@ simple_binary @@ seq [i_swap ; (i_push (prim T_bool) (prim D_True));prim ~children:[seq [dip i_dup; i_exec; i_unpair]] I_LOOP ;i_swap ; i_drop] | C_FOLD_CONTINUE -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_True)); i_pair] | C_FOLD_STOP -> ok @@ simple_unary @@ seq [(i_push (prim T_bool) (prim D_False)); i_pair] | C_SIZE -> ok @@ simple_unary @@ prim I_SIZE | C_FAILWITH -> ok @@ simple_unary @@ prim I_FAILWITH | C_ASSERT_INFERRED -> ok @@ simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit]) | C_ASSERTION -> ok @@ simple_unary @@ i_if (seq [i_push_unit]) (seq [i_push_string "failed assertion" ; i_failwith]) | C_INT -> ok @@ simple_unary @@ prim I_INT | C_ABS -> ok @@ simple_unary @@ prim I_ABS | C_IS_NAT -> ok @@ simple_unary @@ prim I_ISNAT | C_CONS -> ok @@ simple_binary @@ prim I_CONS | C_UNIT -> ok @@ simple_constant @@ prim I_UNIT | C_BALANCE -> ok @@ simple_constant @@ prim I_BALANCE | C_AMOUNT -> ok @@ simple_constant @@ prim I_AMOUNT | C_ADDRESS -> ok @@ simple_unary @@ prim I_ADDRESS | C_SELF_ADDRESS -> ok @@ simple_constant @@ seq [prim I_SELF; prim I_ADDRESS] | C_IMPLICIT_ACCOUNT -> ok @@ simple_unary @@ prim I_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> ok @@ simple_unary @@ prim I_SET_DELEGATE | C_NOW -> ok @@ simple_constant @@ prim I_NOW | C_CALL -> ok @@ simple_ternary @@ prim I_TRANSFER_TOKENS | C_SOURCE -> ok @@ simple_constant @@ prim I_SOURCE | C_SENDER -> ok @@ simple_constant @@ prim I_SENDER | C_SET_MEM -> ok @@ simple_binary @@ prim I_MEM | C_SET_ADD -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE] | C_SET_REMOVE -> ok @@ simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE] | C_SLICE -> ok @@ simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")] | C_SHA256 -> ok @@ simple_unary @@ prim I_SHA256 | C_SHA512 -> ok @@ simple_unary @@ prim I_SHA512 | C_BLAKE2b -> ok @@ simple_unary @@ prim I_BLAKE2B | C_CHECK_SIGNATURE -> ok @@ simple_ternary @@ prim I_CHECK_SIGNATURE | C_HASH_KEY -> ok @@ simple_unary @@ prim I_HASH_KEY | C_BYTES_PACK -> ok @@ simple_unary @@ prim I_PACK | C_CONCAT -> ok @@ simple_binary @@ prim I_CONCAT | C_CHAIN_ID -> ok @@ simple_constant @@ prim I_CHAIN_ID | _ -> simple_fail @@ Format.asprintf "operator not implemented for %a" Stage_common.PP.constant c (* Some complex operators will need to be added in compiler/compiler_program. All operators whose compilations involve a type are found there. *) end