ligo/vendors/ligo-utils/tezos-protocol-alpha/michelson_v1_primitives.ml

(*****************************************************************************)
(*                                                                           *)
(* 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_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_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | 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
  | 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

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_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_MAP -> "EMPTY_MAP"
  | I_EMPTY_SET -> "EMPTY_SET"
  | I_EQ -> "EQ"
  | I_EXEC -> "EXEC"
  | 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"
  | 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"

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
  | "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_MAP" -> ok I_EMPTY_MAP
  | "EMPTY_SET" -> ok I_EMPTY_SET
  | "EQ" -> ok I_EQ
  | "EXEC" -> ok I_EXEC
  | "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
  | "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
  | 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 [
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("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) ;
    ("address", T_address) ;
    (* Alpha_002 addition *)
    ("SLICE", I_SLICE) ;
  ]

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))