ligo/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml
2019-10-17 11:45:27 +02:00

636 lines
18 KiB
OCaml

(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Micheline
type error += Unknown_primitive_name of string
type error += Invalid_case of string
type error += Invalid_primitive_name of string Micheline.canonical * Micheline.canonical_location
type prim =
| K_parameter
| K_storage
| K_code
| D_False
| D_Elt
| D_Left
| D_None
| D_Pair
| D_Right
| D_Some
| D_True
| D_Unit
| I_PACK
| I_UNPACK
| I_BLAKE2B
| I_SHA256
| I_SHA512
| I_ABS
| I_ADD
| I_AMOUNT
| I_AND
| I_BALANCE
| I_CAR
| I_CDR
| I_CHAIN_ID
| I_CHECK_SIGNATURE
| I_COMPARE
| I_CONCAT
| I_CONS
| I_CREATE_ACCOUNT
| I_CREATE_CONTRACT
| I_IMPLICIT_ACCOUNT
| I_DIP
| I_DROP
| I_DUP
| I_EDIV
| I_EMPTY_BIG_MAP
| I_EMPTY_MAP
| I_EMPTY_SET
| I_EQ
| I_EXEC
| I_APPLY
| I_FAILWITH
| I_GE
| I_GET
| I_GT
| I_HASH_KEY
| I_IF
| I_IF_CONS
| I_IF_LEFT
| I_IF_NONE
| I_INT
| I_LAMBDA
| I_LE
| I_LEFT
| I_LOOP
| I_LSL
| I_LSR
| I_LT
| I_MAP
| I_MEM
| I_MUL
| I_NEG
| I_NEQ
| I_NIL
| I_NONE
| I_NOT
| I_NOW
| I_OR
| I_PAIR
| I_PUSH
| I_RIGHT
| I_SIZE
| I_SOME
| I_SOURCE
| I_SENDER
| I_SELF
| I_SLICE
| I_STEPS_TO_QUOTA
| I_SUB
| I_SWAP
| I_TRANSFER_TOKENS
| I_SET_DELEGATE
| I_UNIT
| I_UPDATE
| I_XOR
| I_ITER
| I_LOOP_LEFT
| I_ADDRESS
| I_CONTRACT
| I_ISNAT
| I_CAST
| I_RENAME
| I_DIG
| I_DUG
| T_bool
| T_contract
| T_int
| T_key
| T_key_hash
| T_lambda
| T_list
| T_map
| T_big_map
| T_nat
| T_option
| T_or
| T_pair
| T_set
| T_signature
| T_string
| T_bytes
| T_mutez
| T_timestamp
| T_unit
| T_operation
| T_address
| T_chain_id
let valid_case name =
let is_lower = function '_' | 'a'..'z' -> true | _ -> false in
let is_upper = function '_' | 'A'..'Z' -> true | _ -> false in
let rec for_all a b f =
Compare.Int.(a > b) || f a && for_all (a + 1) b f in
let len = String.length name in
Compare.Int.(len <> 0)
&&
Compare.Char.(String.get name 0 <> '_')
&&
((is_upper (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_upper (String.get name i)))
||
(is_upper (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_lower (String.get name i)))
||
(is_lower (String.get name 0)
&& for_all 1 (len - 1) (fun i -> is_lower (String.get name i))))
let string_of_prim = function
| K_parameter -> "parameter"
| K_storage -> "storage"
| K_code -> "code"
| D_False -> "False"
| D_Elt -> "Elt"
| D_Left -> "Left"
| D_None -> "None"
| D_Pair -> "Pair"
| D_Right -> "Right"
| D_Some -> "Some"
| D_True -> "True"
| D_Unit -> "Unit"
| I_PACK -> "PACK"
| I_UNPACK -> "UNPACK"
| I_BLAKE2B -> "BLAKE2B"
| I_SHA256 -> "SHA256"
| I_SHA512 -> "SHA512"
| I_ABS -> "ABS"
| I_ADD -> "ADD"
| I_AMOUNT -> "AMOUNT"
| I_AND -> "AND"
| I_BALANCE -> "BALANCE"
| I_CAR -> "CAR"
| I_CDR -> "CDR"
| I_CHAIN_ID -> "CHAIN_ID"
| I_CHECK_SIGNATURE -> "CHECK_SIGNATURE"
| I_COMPARE -> "COMPARE"
| I_CONCAT -> "CONCAT"
| I_CONS -> "CONS"
| I_CREATE_ACCOUNT -> "CREATE_ACCOUNT"
| I_CREATE_CONTRACT -> "CREATE_CONTRACT"
| I_IMPLICIT_ACCOUNT -> "IMPLICIT_ACCOUNT"
| I_DIP -> "DIP"
| I_DROP -> "DROP"
| I_DUP -> "DUP"
| I_EDIV -> "EDIV"
| I_EMPTY_BIG_MAP -> "EMPTY_BIG_MAP"
| I_EMPTY_MAP -> "EMPTY_MAP"
| I_EMPTY_SET -> "EMPTY_SET"
| I_EQ -> "EQ"
| I_EXEC -> "EXEC"
| I_APPLY -> "APPLY"
| I_FAILWITH -> "FAILWITH"
| I_GE -> "GE"
| I_GET -> "GET"
| I_GT -> "GT"
| I_HASH_KEY -> "HASH_KEY"
| I_IF -> "IF"
| I_IF_CONS -> "IF_CONS"
| I_IF_LEFT -> "IF_LEFT"
| I_IF_NONE -> "IF_NONE"
| I_INT -> "INT"
| I_LAMBDA -> "LAMBDA"
| I_LE -> "LE"
| I_LEFT -> "LEFT"
| I_LOOP -> "LOOP"
| I_LSL -> "LSL"
| I_LSR -> "LSR"
| I_LT -> "LT"
| I_MAP -> "MAP"
| I_MEM -> "MEM"
| I_MUL -> "MUL"
| I_NEG -> "NEG"
| I_NEQ -> "NEQ"
| I_NIL -> "NIL"
| I_NONE -> "NONE"
| I_NOT -> "NOT"
| I_NOW -> "NOW"
| I_OR -> "OR"
| I_PAIR -> "PAIR"
| I_PUSH -> "PUSH"
| I_RIGHT -> "RIGHT"
| I_SIZE -> "SIZE"
| I_SOME -> "SOME"
| I_SOURCE -> "SOURCE"
| I_SENDER -> "SENDER"
| I_SELF -> "SELF"
| I_SLICE -> "SLICE"
| I_STEPS_TO_QUOTA -> "STEPS_TO_QUOTA"
| I_SUB -> "SUB"
| I_SWAP -> "SWAP"
| I_TRANSFER_TOKENS -> "TRANSFER_TOKENS"
| I_SET_DELEGATE -> "SET_DELEGATE"
| I_UNIT -> "UNIT"
| I_UPDATE -> "UPDATE"
| I_XOR -> "XOR"
| I_ITER -> "ITER"
| I_LOOP_LEFT -> "LOOP_LEFT"
| I_ADDRESS -> "ADDRESS"
| I_CONTRACT -> "CONTRACT"
| I_ISNAT -> "ISNAT"
| I_CAST -> "CAST"
| I_RENAME -> "RENAME"
| I_DIG -> "DIG"
| I_DUG -> "DUG"
| T_bool -> "bool"
| T_contract -> "contract"
| T_int -> "int"
| T_key -> "key"
| T_key_hash -> "key_hash"
| T_lambda -> "lambda"
| T_list -> "list"
| T_map -> "map"
| T_big_map -> "big_map"
| T_nat -> "nat"
| T_option -> "option"
| T_or -> "or"
| T_pair -> "pair"
| T_set -> "set"
| T_signature -> "signature"
| T_string -> "string"
| T_bytes -> "bytes"
| T_mutez -> "mutez"
| T_timestamp -> "timestamp"
| T_unit -> "unit"
| T_operation -> "operation"
| T_address -> "address"
| T_chain_id -> "chain_id"
let prim_of_string = function
| "parameter" -> ok K_parameter
| "storage" -> ok K_storage
| "code" -> ok K_code
| "False" -> ok D_False
| "Elt" -> ok D_Elt
| "Left" -> ok D_Left
| "None" -> ok D_None
| "Pair" -> ok D_Pair
| "Right" -> ok D_Right
| "Some" -> ok D_Some
| "True" -> ok D_True
| "Unit" -> ok D_Unit
| "PACK" -> ok I_PACK
| "UNPACK" -> ok I_UNPACK
| "BLAKE2B" -> ok I_BLAKE2B
| "SHA256" -> ok I_SHA256
| "SHA512" -> ok I_SHA512
| "ABS" -> ok I_ABS
| "ADD" -> ok I_ADD
| "AMOUNT" -> ok I_AMOUNT
| "AND" -> ok I_AND
| "BALANCE" -> ok I_BALANCE
| "CAR" -> ok I_CAR
| "CDR" -> ok I_CDR
| "CHAIN_ID" -> ok I_CHAIN_ID
| "CHECK_SIGNATURE" -> ok I_CHECK_SIGNATURE
| "COMPARE" -> ok I_COMPARE
| "CONCAT" -> ok I_CONCAT
| "CONS" -> ok I_CONS
| "CREATE_ACCOUNT" -> ok I_CREATE_ACCOUNT
| "CREATE_CONTRACT" -> ok I_CREATE_CONTRACT
| "IMPLICIT_ACCOUNT" -> ok I_IMPLICIT_ACCOUNT
| "DIP" -> ok I_DIP
| "DROP" -> ok I_DROP
| "DUP" -> ok I_DUP
| "EDIV" -> ok I_EDIV
| "EMPTY_BIG_MAP" -> ok I_EMPTY_BIG_MAP
| "EMPTY_MAP" -> ok I_EMPTY_MAP
| "EMPTY_SET" -> ok I_EMPTY_SET
| "EQ" -> ok I_EQ
| "EXEC" -> ok I_EXEC
| "APPLY" -> ok I_APPLY
| "FAILWITH" -> ok I_FAILWITH
| "GE" -> ok I_GE
| "GET" -> ok I_GET
| "GT" -> ok I_GT
| "HASH_KEY" -> ok I_HASH_KEY
| "IF" -> ok I_IF
| "IF_CONS" -> ok I_IF_CONS
| "IF_LEFT" -> ok I_IF_LEFT
| "IF_NONE" -> ok I_IF_NONE
| "INT" -> ok I_INT
| "LAMBDA" -> ok I_LAMBDA
| "LE" -> ok I_LE
| "LEFT" -> ok I_LEFT
| "LOOP" -> ok I_LOOP
| "LSL" -> ok I_LSL
| "LSR" -> ok I_LSR
| "LT" -> ok I_LT
| "MAP" -> ok I_MAP
| "MEM" -> ok I_MEM
| "MUL" -> ok I_MUL
| "NEG" -> ok I_NEG
| "NEQ" -> ok I_NEQ
| "NIL" -> ok I_NIL
| "NONE" -> ok I_NONE
| "NOT" -> ok I_NOT
| "NOW" -> ok I_NOW
| "OR" -> ok I_OR
| "PAIR" -> ok I_PAIR
| "PUSH" -> ok I_PUSH
| "RIGHT" -> ok I_RIGHT
| "SIZE" -> ok I_SIZE
| "SOME" -> ok I_SOME
| "SOURCE" -> ok I_SOURCE
| "SENDER" -> ok I_SENDER
| "SELF" -> ok I_SELF
| "SLICE" -> ok I_SLICE
| "STEPS_TO_QUOTA" -> ok I_STEPS_TO_QUOTA
| "SUB" -> ok I_SUB
| "SWAP" -> ok I_SWAP
| "TRANSFER_TOKENS" -> ok I_TRANSFER_TOKENS
| "SET_DELEGATE" -> ok I_SET_DELEGATE
| "UNIT" -> ok I_UNIT
| "UPDATE" -> ok I_UPDATE
| "XOR" -> ok I_XOR
| "ITER" -> ok I_ITER
| "LOOP_LEFT" -> ok I_LOOP_LEFT
| "ADDRESS" -> ok I_ADDRESS
| "CONTRACT" -> ok I_CONTRACT
| "ISNAT" -> ok I_ISNAT
| "CAST" -> ok I_CAST
| "RENAME" -> ok I_RENAME
| "DIG" -> ok I_DIG
| "DUG" -> ok I_DUG
| "bool" -> ok T_bool
| "contract" -> ok T_contract
| "int" -> ok T_int
| "key" -> ok T_key
| "key_hash" -> ok T_key_hash
| "lambda" -> ok T_lambda
| "list" -> ok T_list
| "map" -> ok T_map
| "big_map" -> ok T_big_map
| "nat" -> ok T_nat
| "option" -> ok T_option
| "or" -> ok T_or
| "pair" -> ok T_pair
| "set" -> ok T_set
| "signature" -> ok T_signature
| "string" -> ok T_string
| "bytes" -> ok T_bytes
| "mutez" -> ok T_mutez
| "timestamp" -> ok T_timestamp
| "unit" -> ok T_unit
| "operation" -> ok T_operation
| "address" -> ok T_address
| "chain_id" -> ok T_chain_id
| n ->
if valid_case n then
error (Unknown_primitive_name n)
else
error (Invalid_case n)
let prims_of_strings expr =
let rec convert = function
| Int _ | String _ | Bytes _ as expr -> ok expr
| Prim (loc, prim, args, annot) ->
Error_monad.record_trace
(Invalid_primitive_name (expr, loc))
(prim_of_string prim) >>? fun prim ->
List.fold_left
(fun acc arg ->
acc >>? fun args ->
convert arg >>? fun arg ->
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Prim (0, prim, List.rev args, annot))
| Seq (_, args) ->
List.fold_left
(fun acc arg ->
acc >>? fun args ->
convert arg >>? fun arg ->
ok (arg :: args))
(ok []) args >>? fun args ->
ok (Seq (0, List.rev args)) in
convert (root expr) >>? fun expr ->
ok (strip_locations expr)
let strings_of_prims expr =
let rec convert = function
| Int _ | String _ | Bytes _ as expr -> expr
| Prim (_, prim, args, annot) ->
let prim = string_of_prim prim in
let args = List.map convert args in
Prim (0, prim, args, annot)
| Seq (_, args) ->
let args = List.map convert args in
Seq (0, args) in
strip_locations (convert (root expr))
let prim_encoding =
let open Data_encoding in
def "michelson.v1.primitives" @@
string_enum [
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("parameter", K_parameter) ;
("storage", K_storage) ;
("code", K_code) ;
("False", D_False) ;
("Elt", D_Elt) ;
("Left", D_Left) ;
("None", D_None) ;
("Pair", D_Pair) ;
("Right", D_Right) ;
("Some", D_Some) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("True", D_True) ;
("Unit", D_Unit) ;
("PACK", I_PACK) ;
("UNPACK", I_UNPACK) ;
("BLAKE2B", I_BLAKE2B) ;
("SHA256", I_SHA256) ;
("SHA512", I_SHA512) ;
("ABS", I_ABS) ;
("ADD", I_ADD) ;
("AMOUNT", I_AMOUNT) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("AND", I_AND) ;
("BALANCE", I_BALANCE) ;
("CAR", I_CAR) ;
("CDR", I_CDR) ;
("CHECK_SIGNATURE", I_CHECK_SIGNATURE) ;
("COMPARE", I_COMPARE) ;
("CONCAT", I_CONCAT) ;
("CONS", I_CONS) ;
("CREATE_ACCOUNT", I_CREATE_ACCOUNT) ;
("CREATE_CONTRACT", I_CREATE_CONTRACT) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT) ;
("DIP", I_DIP) ;
("DROP", I_DROP) ;
("DUP", I_DUP) ;
("EDIV", I_EDIV) ;
("EMPTY_MAP", I_EMPTY_MAP) ;
("EMPTY_SET", I_EMPTY_SET) ;
("EQ", I_EQ) ;
("EXEC", I_EXEC) ;
("FAILWITH", I_FAILWITH) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("GE", I_GE) ;
("GET", I_GET) ;
("GT", I_GT) ;
("HASH_KEY", I_HASH_KEY) ;
("IF", I_IF) ;
("IF_CONS", I_IF_CONS) ;
("IF_LEFT", I_IF_LEFT) ;
("IF_NONE", I_IF_NONE) ;
("INT", I_INT) ;
("LAMBDA", I_LAMBDA) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("LE", I_LE) ;
("LEFT", I_LEFT) ;
("LOOP", I_LOOP) ;
("LSL", I_LSL) ;
("LSR", I_LSR) ;
("LT", I_LT) ;
("MAP", I_MAP) ;
("MEM", I_MEM) ;
("MUL", I_MUL) ;
("NEG", I_NEG) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("NEQ", I_NEQ) ;
("NIL", I_NIL) ;
("NONE", I_NONE) ;
("NOT", I_NOT) ;
("NOW", I_NOW) ;
("OR", I_OR) ;
("PAIR", I_PAIR) ;
("PUSH", I_PUSH) ;
("RIGHT", I_RIGHT) ;
("SIZE", I_SIZE) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("SOME", I_SOME) ;
("SOURCE", I_SOURCE) ;
("SENDER", I_SENDER) ;
("SELF", I_SELF) ;
("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA) ;
("SUB", I_SUB) ;
("SWAP", I_SWAP) ;
("TRANSFER_TOKENS", I_TRANSFER_TOKENS) ;
("SET_DELEGATE", I_SET_DELEGATE) ;
("UNIT", I_UNIT) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("UPDATE", I_UPDATE) ;
("XOR", I_XOR) ;
("ITER", I_ITER) ;
("LOOP_LEFT", I_LOOP_LEFT) ;
("ADDRESS", I_ADDRESS) ;
("CONTRACT", I_CONTRACT) ;
("ISNAT", I_ISNAT) ;
("CAST", I_CAST) ;
("RENAME", I_RENAME) ;
("bool", T_bool) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("contract", T_contract) ;
("int", T_int) ;
("key", T_key) ;
("key_hash", T_key_hash) ;
("lambda", T_lambda) ;
("list", T_list) ;
("map", T_map) ;
("big_map", T_big_map) ;
("nat", T_nat) ;
("option", T_option) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("or", T_or) ;
("pair", T_pair) ;
("set", T_set) ;
("signature", T_signature) ;
("string", T_string) ;
("bytes", T_bytes) ;
("mutez", T_mutez) ;
("timestamp", T_timestamp) ;
("unit", T_unit) ;
("operation", T_operation) ;
(* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
("address", T_address) ;
(* Alpha_002 addition *)
("SLICE", I_SLICE) ;
(* Alpha_005 addition *)
("DIG", I_DIG) ;
("DUG", I_DUG) ;
("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP) ;
("APPLY", I_APPLY) ;
("chain_id", T_chain_id) ;
("CHAIN_ID", I_CHAIN_ID)
(* New instructions must be added here, for backward compatibility of the encoding. *)
]
let () =
register_error_kind
`Permanent
~id:"michelson_v1.unknown_primitive_name"
~title: "Unknown primitive name"
~description:
"In a script or data expression, a primitive was unknown."
~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
Data_encoding.(obj1 (req "wrong_primitive_name" string))
(function
| Unknown_primitive_name got -> Some got
| _ -> None)
(fun got ->
Unknown_primitive_name got) ;
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive_name_case"
~title: "Invalid primitive name case"
~description:
"In a script or data expression, a primitive name is \
neither uppercase, lowercase or capitalized."
~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n)
Data_encoding.(obj1 (req "wrong_primitive_name" string))
(function
| Invalid_case name -> Some name
| _ -> None)
(fun name ->
Invalid_case name) ;
register_error_kind
`Permanent
~id:"michelson_v1.invalid_primitive_name"
~title: "Invalid primitive name"
~description:
"In a script or data expression, a primitive name is \
unknown or has a wrong case."
~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.")
Data_encoding.(obj2
(req "expression" (Micheline.canonical_encoding ~variant:"generic" string))
(req "location" Micheline.canonical_location_encoding))
(function
| Invalid_primitive_name (expr, loc) -> Some (expr, loc)
| _ -> None)
(fun (expr, loc) ->
Invalid_primitive_name (expr, loc))