(**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) (* Dynamic Ledger Solutions, Inc. *) (* *) (* All rights reserved. No warranty, explicit or implicit, provided. *) (* *) (**************************************************************************) open Tezos_context open Script_int open Script open Script_typed_ir (* ---- Error definitions ---------------------------------------------------*) (* Auxiliary types for error documentation *) type namespace = Type_namespace | Constant_namespace | Instr_namespace type kind = Int_kind | String_kind | Prim_kind | Seq_kind (* Structure errors *) type error += Invalid_arity of Script.location * string * int * int type error += Invalid_namespace of Script.location * string * namespace * namespace type error += Invalid_primitive of Script.location * string list * string type error += Invalid_case of Script.location * string type error += Invalid_kind of Script.location * kind list * kind (* Instruction typing errors *) type error += Fail_not_in_tail_position of Script.location type error += Undefined_cast : Script.location * _ ty * _ ty -> error type error += Undefined_binop : Script.location * string * _ ty * _ ty -> error type error += Undefined_unop : Script.location * string * _ ty -> error type error += Bad_return : Script.location * _ stack_ty * _ ty -> error type error += Bad_stack : Script.location * string * int * _ stack_ty -> error type error += Unmatched_branches : Script.location * _ stack_ty * _ stack_ty -> error type error += Transfer_in_lambda of Script.location type error += Bad_stack_length type error += Bad_stack_item of int (* Value typing errors *) type error += Invalid_constant : Script.location * Script.expr * _ ty -> error type error += Invalid_contract of Script.location * Contract.t type error += Comparable_type_expected : Script.location * _ ty -> error type error += Inconsistent_types : _ ty * _ ty -> error type error += Bad_sign : _ ty -> error (* Toplevel errors *) type error += Ill_typed_data : string option * Script.expr * _ ty -> error type error += Ill_formed_type of string option * Script.expr type error += Ill_typed_contract : Script.expr * _ ty * _ ty * _ ty -> error (* ---- Error helpers -------------------------------------------------------*) let location = function | Prim (loc, _, _) | Int (loc, _) | String (loc, _) | Seq (loc, _) -> loc let kind = function | Int _ -> Int_kind | String _ -> String_kind | Prim _ -> Prim_kind | Seq _ -> Seq_kind let namespace 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 if Compare.Int.(len = 0) || Compare.Char.(String.get name 0 = '_') then None else if is_upper (String.get name 0) && for_all 1 (len - 1) (fun i -> is_upper (String.get name i)) then Some Instr_namespace else if is_upper (String.get name 0) && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)) then Some Constant_namespace else if is_lower (String.get name 0) && for_all 1 (len - 1) (fun i -> is_lower (String.get name i)) then Some Type_namespace else None let unexpected expr exp_kinds exp_ns exp_prims = match expr with | Int (loc, _) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind) | String (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind) | Seq (loc, _ ) -> Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind) | Prim (loc, name, _) -> match namespace name, exp_ns with | None, _ -> Invalid_case (loc, name) | Some Type_namespace, Type_namespace | Some Instr_namespace, Instr_namespace | Some Constant_namespace, Constant_namespace -> Invalid_primitive (loc, exp_prims, name) | Some ns, _ -> Invalid_namespace (loc, name, exp_ns, ns) let check_kind kinds expr = let kind = kind expr in if List.mem kind kinds then return () else let loc = location expr in fail (Invalid_kind (loc, kinds, kind)) (* ---- Sets and Maps -------------------------------------------------------*) let compare_comparable : type a. a comparable_ty -> a -> a -> int = fun kind x y -> match kind with | String_key -> Compare.String.compare x y | Bool_key -> Compare.Bool.compare x y | Tez_key -> Tez.compare x y | Key_key -> Ed25519.Public_key_hash.compare x y | Int_key kind -> let res = Script_int.to_int64 Script_int.Int64 (Script_int.compare kind x y) in if Compare.Int64.(res = 0L) then 0 else if Compare.Int64.(res > 0L) then 1 else -1 | Timestamp_key -> Timestamp.compare x y let empty_set : type a. a comparable_ty -> a set = fun ty -> let module OPS = Set.Make (struct type t = a let compare = compare_comparable ty end) in (module struct type elt = a module OPS = OPS let boxed = OPS.empty end) let set_update : type a. a -> bool -> a set -> a set = fun v b (module Box) -> (module struct type elt = a module OPS = Box.OPS let boxed = if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed end) let set_mem : type elt. elt -> elt set -> bool = fun v (module Box) -> Box.OPS.mem v Box.boxed let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc = fun f (module Box) -> Box.OPS.fold f Box.boxed let map_key_ty : type a b. (a, b) map -> a comparable_ty = fun (module Box) -> Box.key_ty let empty_map : type a b. a comparable_ty -> (a, b) map = fun ty -> let module OPS = Map.Make (struct type t = a let compare = compare_comparable ty end) in (module struct type key = a type value = b let key_ty = ty module OPS = OPS let boxed = OPS.empty end) let map_get : type key value. key -> (key, value) map -> value option = fun k (module Box) -> try Some (Box.OPS.find k Box.boxed) with Not_found -> None let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map = fun k v (module Box) -> (module struct type key = a type value = b let key_ty = Box.key_ty module OPS = Box.OPS let boxed = match v with | Some v -> Box.OPS.add k v Box.boxed | None -> Box.OPS.remove k Box.boxed end) let map_mem : type key value. key -> (key, value) map -> bool = fun k (module Box) -> Box.OPS.mem k Box.boxed let map_fold : type key value acc. (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc = fun f (module Box) -> Box.OPS.fold f Box.boxed (* ---- Unparsing (Typed IR -> Untyped epressions) --------------------------*) let ty_of_comparable_ty : type a. a comparable_ty -> a ty = function | Int_key k -> Int_t k | String_key -> String_t | Tez_key -> Tez_t | Bool_key -> Bool_t | Key_key -> Key_t | Timestamp_key -> Timestamp_t let unparse_comparable_ty : type a. a comparable_ty -> Script.expr = function | Int_key Int8 -> Prim (-1, "int8", []) | Int_key Int16 -> Prim (-1, "int16", []) | Int_key Int32 -> Prim (-1, "int32", []) | Int_key Int64 -> Prim (-1, "int64", []) | Int_key Uint8 -> Prim (-1, "uint8", []) | Int_key Uint16 -> Prim (-1, "uint16", []) | Int_key Uint32 -> Prim (-1, "uint32", []) | Int_key Uint64 -> Prim (-1, "uint64", []) | String_key -> Prim (-1, "string", []) | Tez_key -> Prim (-1, "tez", []) | Bool_key -> Prim (-1, "bool", []) | Key_key -> Prim (-1, "key", []) | Timestamp_key -> Prim (-1, "timestamp", []) let rec unparse_ty : type a. a ty -> Script.expr = function | Unit_t -> Prim (-1, "unit", []) | Int_t Int8 -> Prim (-1, "int8", []) | Int_t Int16 -> Prim (-1, "int16", []) | Int_t Int32 -> Prim (-1, "int32", []) | Int_t Int64 -> Prim (-1, "int64", []) | Int_t Uint8 -> Prim (-1, "uint8", []) | Int_t Uint16 -> Prim (-1, "uint16", []) | Int_t Uint32 -> Prim (-1, "uint32", []) | Int_t Uint64 -> Prim (-1, "uint64", []) | String_t -> Prim (-1, "string", []) | Tez_t -> Prim (-1, "tez", []) | Bool_t -> Prim (-1, "bool", []) | Key_t -> Prim (-1, "key", []) | Timestamp_t -> Prim (-1, "timestamp", []) | Signature_t -> Prim (-1, "signature", []) | Contract_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in Prim (-1, "contract", [ tl; tr ]) | Pair_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in Prim (-1, "pair", [ tl; tr ]) | Union_t (utl, utr) -> let tl = unparse_ty utl in let tr = unparse_ty utr in Prim (-1, "or", [ tl; tr ]) | Lambda_t (uta, utr) -> let ta = unparse_ty uta in let tr = unparse_ty utr in Prim (-1, "lambda", [ ta; tr ]) | Option_t ut -> let t = unparse_ty ut in Prim (-1, "option", [ t ]) | List_t ut -> let t = unparse_ty ut in Prim (-1, "list", [ t ]) | Set_t ut -> let t = unparse_comparable_ty ut in Prim (-1, "set", [ t ]) | Map_t (uta, utr) -> let ta = unparse_comparable_ty uta in let tr = unparse_ty utr in Prim (-1, "map", [ ta; tr ]) let rec unparse_data : type a. a ty -> a -> Script.expr = fun ty a -> match ty, a with | Unit_t, () -> Prim (-1, "Unit", []) | Int_t k, v -> Int (-1, Int64.to_string (to_int64 k v)) | String_t, s -> String (-1, s) | Bool_t, true -> Prim (-1, "True", []) | Bool_t, false -> Prim (-1, "False", []) | Timestamp_t, t -> String (-1, Timestamp.to_notation t) | Contract_t _, (_, _, c) -> String (-1, Contract.to_b58check c) | Signature_t, s -> let text = Hex_encode.hex_encode (MBytes.to_string (Data_encoding.Binary.to_bytes Ed25519.Signature.encoding s)) in String (-1, text) | Tez_t, v -> String (-1, Tez.to_string v) | Key_t, k -> String (-1, Ed25519.Public_key_hash.to_b58check k) | Pair_t (tl, tr), (l, r) -> let l = unparse_data tl l in let r = unparse_data tr r in Prim (-1, "Pair", [ l; r ]) | Union_t (tl, _), L l -> let l = unparse_data tl l in Prim (-1, "Left", [ l ]) | Union_t (_, tr), R r -> let r = unparse_data tr r in Prim (-1, "Right", [ r ]) | Option_t t, Some v -> let v = unparse_data t v in Prim (-1, "Some", [ v ]) | Option_t _, None -> Prim (-1, "None", []) | List_t t, items -> let items = List.map (unparse_data t) items in Prim (-1, "List", items) | Set_t t, set -> let t = ty_of_comparable_ty t in let items = set_fold (fun item acc -> unparse_data t item :: acc ) set [] in Prim (-1, "Set", items) | Map_t (kt, vt), map -> let kt = ty_of_comparable_ty kt in let items = map_fold (fun k v acc -> Prim (-1, "Item", [ unparse_data kt k; unparse_data vt v ]) :: acc) map [] in Prim (-1, "Map", items) | Lambda_t _, Lam (_, original_code) -> original_code (* ---- Equality witnesses --------------------------------------------------*) type ('ta, 'tb) eq = | Eq : 'same * 'same -> ('same, 'same) eq let eq : type t. t -> t -> (t, t) eq tzresult = fun ta tb -> Ok (Eq (ta, tb)) let int_kind_eq : type sa la sb lb. (sa, la) int_kind -> (sb, lb) int_kind -> ((sa, la) int_kind, (sb, lb) int_kind) eq tzresult = fun ka kb -> match ka, kb with | Int8, Int8 -> eq ka kb | Uint8, Uint8 -> eq ka kb | Int16, Int16 -> eq ka kb | Uint16, Uint16 -> eq ka kb | Int32, Int32 -> eq ka kb | Uint32, Uint32 -> eq ka kb | Int64, Int64 -> eq ka kb | Uint64, Uint64 -> eq ka kb | _ -> error @@ Inconsistent_types (Int_t ka, Int_t kb) let unsigned_int_kind : type sa la. (sa, la) int_kind -> (sa, unsigned) eq tzresult = fun kind -> match kind with | Uint8 -> eq Unsigned Unsigned | Uint16 -> eq Unsigned Unsigned | Uint32 -> eq Unsigned Unsigned | Uint64 -> eq Unsigned Unsigned | _ -> error @@ Bad_sign (Int_t kind) let signed_int_kind : type sa la. (sa, la) int_kind -> (sa, signed) eq tzresult = fun kind -> match kind with | Int8 -> eq Signed Signed | Int16 -> eq Signed Signed | Int32 -> eq Signed Signed | Int64 -> eq Signed Signed | _ -> error @@ Bad_sign (Int_t kind) let comparable_ty_eq : type ta tb. ta comparable_ty -> tb comparable_ty -> (ta comparable_ty, tb comparable_ty) eq tzresult = fun ta tb -> match ta, tb with | Int_key ka, Int_key kb -> int_kind_eq ka kb >>? fun (Eq _) -> (eq ta tb : (ta comparable_ty, tb comparable_ty) eq tzresult) | String_key, String_key -> eq ta tb | Tez_key, Tez_key -> eq ta tb | Bool_key, Bool_key -> eq ta tb | Key_key, Key_key -> eq ta tb | Timestamp_key, Timestamp_key -> eq ta tb | _, _ -> error (Inconsistent_types (ty_of_comparable_ty ta, ty_of_comparable_ty tb)) let rec ty_eq : type ta tb. ta ty -> tb ty -> (ta ty, tb ty) eq tzresult = fun ta tb -> match ta, tb with | Unit_t, Unit_t -> eq ta tb | Int_t ka, Int_t kb -> int_kind_eq ka kb >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult) | Key_t, Key_t -> eq ta tb | String_t, String_t -> eq ta tb | Signature_t, Signature_t -> eq ta tb | Tez_t, Tez_t -> eq ta tb | Timestamp_t, Timestamp_t -> eq ta tb | Bool_t, Bool_t -> eq ta tb | Map_t (tal, tar), Map_t (tbl, tbr) -> (comparable_ty_eq tal tbl >>? fun (Eq _) -> ty_eq tar tbr >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Set_t ea, Set_t eb -> (comparable_ty_eq ea eb >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Pair_t (tal, tar), Pair_t (tbl, tbr) -> (ty_eq tal tbl >>? fun (Eq _) -> ty_eq tar tbr >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Union_t (tal, tar), Union_t (tbl, tbr) -> (ty_eq tal tbl >>? fun (Eq _) -> ty_eq tar tbr >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Lambda_t (tal, tar), Lambda_t (tbl, tbr) -> (ty_eq tal tbl >>? fun (Eq _) -> ty_eq tar tbr >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Contract_t (tal, tar), Contract_t (tbl, tbr) -> (ty_eq tal tbl >>? fun (Eq _) -> ty_eq tar tbr >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | Option_t tva, Option_t tvb -> (ty_eq tva tvb >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | List_t tva, List_t tvb -> (ty_eq tva tvb >>? fun (Eq _) -> (eq ta tb : (ta ty, tb ty) eq tzresult)) |> record_trace (Inconsistent_types (ta, tb)) | _, _ -> error (Inconsistent_types (ta, tb)) let rec stack_ty_eq : type ta tb. int -> ta stack_ty -> tb stack_ty -> (ta stack_ty, tb stack_ty) eq tzresult = fun lvl ta tb -> match ta, tb with | Item_t (tva, ra), Item_t (tvb, rb) -> ty_eq tva tvb |> record_trace (Bad_stack_item lvl) >>? fun (Eq _) -> stack_ty_eq (lvl + 1) ra rb >>? fun (Eq _) -> (eq ta tb : (ta stack_ty, tb stack_ty) eq tzresult) | Empty_t, Empty_t -> eq ta tb | _, _ -> error Bad_stack_length (* ---- Type checker resuls -------------------------------------------------*) type 'bef judgement = | Typed : ('bef, 'aft) descr -> 'bef judgement | Failed : { descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr } -> 'bef judgement (* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*) type ('t, 'f, 'b) branch = { branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr } [@@unboxed] let merge_branches : type bef a b. int -> a judgement -> b judgement -> (a, b, bef) branch -> bef judgement tzresult Lwt.t = fun loc btr bfr { branch } -> match btr, bfr with | Typed ({ aft = aftbt } as dbt), Typed ({ aft = aftbf } as dbf) -> trace (Unmatched_branches (loc, aftbt, aftbf)) (Lwt.return (stack_ty_eq 1 aftbt aftbf)) >>=? fun (Eq _) -> return (Typed (branch dbt dbf)) | Failed { descr = descrt }, Failed { descr = descrf } -> let descr ret = branch (descrt ret) (descrf ret) in return (Failed { descr }) | Typed dbt, Failed { descr = descrf } -> return (Typed (branch dbt (descrf dbt.aft))) | Failed { descr = descrt }, Typed dbf -> return (Typed (branch (descrt dbf.aft) dbf)) type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty type ex_ty = Ex_ty : 'a ty -> ex_ty type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty type ex_int_kind = Ex_int_kind : ('s, 'l) int_kind -> ex_int_kind let rec parse_comparable_ty : Script.expr -> ex_comparable_ty tzresult = function | Prim (_, "int8", []) -> ok (Ex_comparable_ty (Int_key Int8)) | Prim (_, "int16", []) -> ok (Ex_comparable_ty (Int_key Int16)) | Prim (_, "int32", []) -> ok (Ex_comparable_ty (Int_key Int32)) | Prim (_, "int64", []) -> ok (Ex_comparable_ty (Int_key Int64)) | Prim (_, "uint8", []) -> ok (Ex_comparable_ty (Int_key Uint8)) | Prim (_, "uint16", []) -> ok (Ex_comparable_ty (Int_key Uint16)) | Prim (_, "uint32", []) -> ok (Ex_comparable_ty (Int_key Uint32)) | Prim (_, "uint64", []) -> ok (Ex_comparable_ty (Int_key Uint64)) | Prim (_, "string", []) -> ok (Ex_comparable_ty String_key) | Prim (_, "tez", []) -> ok (Ex_comparable_ty Tez_key) | Prim (_, "bool", []) -> ok (Ex_comparable_ty Bool_key) | Prim (_, "key", []) -> ok (Ex_comparable_ty Key_key) | Prim (_, "timestamp", []) -> ok (Ex_comparable_ty Timestamp_key) | Prim (loc, ("int8" | "int16" | "int32" | "int64" | "uint8" | "uint16" | "uint32" | "uint64" | "string" | "tez" | "bool" | "key" | "timestamp" as prim), l) -> error (Invalid_arity (loc, prim, 0, List.length l)) | Prim (loc, ("pair" | "or" | "set" | "map" | "list" | "option" | "lambda" | "unit" | "signature" | "contract"), _) as expr -> parse_ty expr >>? fun (Ex_ty ty) -> error (Comparable_type_expected (loc, ty)) | expr -> error @@ unexpected expr [] Type_namespace [ "int8" ; "int16" ; "int32" ; "int64" ; "uint8" ; "uint16" ; "uint32" ; "uint64" ; "string" ; "tez" ; "bool" ; "key" ; "timestamp" ] and parse_ty : Script.expr -> ex_ty tzresult = function | Prim (_, "unit", []) -> ok (Ex_ty Unit_t) | Prim (_, "int8", []) -> ok (Ex_ty (Int_t Int8)) | Prim (_, "int16", []) -> ok (Ex_ty (Int_t Int16)) | Prim (_, "int32", []) -> ok (Ex_ty (Int_t Int32)) | Prim (_, "int64", []) -> ok (Ex_ty (Int_t Int64)) | Prim (_, "uint8", []) -> ok (Ex_ty (Int_t Uint8)) | Prim (_, "uint16", []) -> ok (Ex_ty (Int_t Uint16)) | Prim (_, "uint32", []) -> ok (Ex_ty (Int_t Uint32)) | Prim (_, "uint64", []) -> ok (Ex_ty (Int_t Uint64)) | Prim (_, "string", []) -> ok (Ex_ty String_t) | Prim (_, "tez", []) -> ok (Ex_ty Tez_t) | Prim (_, "bool", []) -> ok (Ex_ty Bool_t) | Prim (_, "key", []) -> ok (Ex_ty Key_t) | Prim (_, "timestamp", []) -> ok (Ex_ty Timestamp_t) | Prim (_, "signature", []) -> ok (Ex_ty Signature_t) | Prim (_, "contract", [ utl; utr ]) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Contract_t (tl, tr))) | Prim (_, "pair", [ utl; utr ]) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Pair_t (tl, tr))) | Prim (_, "or", [ utl; utr ]) -> parse_ty utl >>? fun (Ex_ty tl) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Union_t (tl, tr))) | Prim (_, "lambda", [ uta; utr ]) -> parse_ty uta >>? fun (Ex_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Lambda_t (ta, tr))) | Prim (_, "option", [ ut ]) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (Option_t t)) | Prim (_, "list", [ ut ]) -> parse_ty ut >>? fun (Ex_ty t) -> ok (Ex_ty (List_t t)) | Prim (_, "set", [ ut ]) -> parse_comparable_ty ut >>? fun (Ex_comparable_ty t) -> ok (Ex_ty (Set_t t)) | Prim (_, "map", [ uta; utr ]) -> parse_comparable_ty uta >>? fun (Ex_comparable_ty ta) -> parse_ty utr >>? fun (Ex_ty tr) -> ok (Ex_ty (Map_t (ta, tr))) | Prim (loc, ("pair" | "or" | "set" | "map" | "list" | "option" | "lambda" | "unit" | "signature" | "contract" | "int8" | "int16" | "int32" | "int64" | "uint8" | "uint16" | "uint32" | "uint64" | "string" | "tez" | "bool" | "key" | "timestamp" as prim), l) -> error (Invalid_arity (loc, prim, 0, List.length l)) | expr -> error @@ unexpected expr [] Type_namespace [ "pair" ; "or" ; "set" ; "map" ; "list" ; "option" ; "lambda" ; "unit" ; "signature" ; "contract" ; "int8" ; "int16" ; "int32" ; "int64" ; "uint8" ; "uint16" ; "uint32" ; "uint64" ; "string" ; "tez" ; "bool" ; "key" ; "timestamp" ] let comparable_ty_of_ty : type a. int -> a ty -> a comparable_ty tzresult = fun loc ty -> match ty with | Int_t k -> ok (Int_key k) | String_t -> ok String_key | Tez_t -> ok Tez_key | Bool_t -> ok Bool_key | Key_t -> ok Key_key | Timestamp_t -> ok Timestamp_key | ty -> error (Comparable_type_expected (loc, ty)) let rec parse_data : type a. context -> a ty -> Script.expr -> a tzresult Lwt.t = fun ctxt ty script_data -> let error () = Invalid_constant (location script_data, script_data, ty) in let traced body = trace (error ()) body in match ty, script_data with (* Unit *) | Unit_t, Prim (_, "Unit", []) -> return () | Unit_t, Prim (loc, "Unit", l) -> traced (fail (Invalid_arity (loc, "Unit", 0, List.length l))) | Unit_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Unit" ])) (* Booleans *) | Bool_t, Prim (_, "True", []) -> return true | Bool_t, Prim (_, "False", []) -> return false | Bool_t, Prim (loc, ("True" | "False" as c), l) -> traced (fail (Invalid_arity (loc, c, 0, List.length l))) | Bool_t, expr -> traced (fail (unexpected expr [] Constant_namespace [ "True" ; "False" ])) (* Strings *) | String_t, String (_, v) -> return v | String_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Integers *) | Int_t k, Int (_, v) -> begin try match checked_of_int64 k (Int64.of_string v) with | None -> raise Exit | Some i -> return i with _ -> fail (error ()) end | Int_t _, expr -> traced (fail (Invalid_kind (location expr, [ Int_kind ], kind expr))) (* Tez amounts *) | Tez_t, String (_, v) -> begin try match Tez.of_string v with | None -> raise Exit | Some tez -> return tez with _ -> fail @@ error () end | Tez_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Timestamps *) | Timestamp_t, (Int (_, v)) -> begin match (Timestamp.of_seconds v) with | Some v -> return v | None -> fail (error ()) end | Timestamp_t, String (_, s) -> begin try match Timestamp.of_notation s with | Some v -> return v | None -> fail (error ()) with _ -> fail (error ()) end | Timestamp_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ; Int_kind ], kind expr))) (* IDs *) | Key_t, String (_, s) -> begin try return (Ed25519.Public_key_hash.of_b58check s) with _ -> fail (error ()) end | Key_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Signatures *) | Signature_t, String (_, s) -> begin try match Data_encoding.Binary.of_bytes Ed25519.Signature.encoding (MBytes.of_string (Hex_encode.hex_decode s)) with | Some s -> return s | None -> raise Not_found with _ -> fail (error ()) end | Signature_t, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Contracts *) | Contract_t (ty1, ty2), String (loc, s) -> traced @@ (Lwt.return (Contract.of_b58check s)) >>=? fun c -> parse_contract ctxt ty1 ty2 loc c >>=? fun _ -> return (ty1, ty2, c) | Contract_t _, expr -> traced (fail (Invalid_kind (location expr, [ String_kind ], kind expr))) (* Pairs *) | Pair_t (ta, tb), Prim (_, "Pair", [ va; vb ]) -> traced @@ parse_data ctxt ta va >>=? fun va -> parse_data ctxt tb vb >>=? fun vb -> return (va, vb) | Pair_t _, Prim (loc, "Pair", l) -> fail @@ Invalid_arity (loc, "Pair", 2, List.length l) | Pair_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Pair" ])) (* Unions *) | Union_t (tl, _), Prim (_, "Left", [ v ]) -> traced @@ parse_data ctxt tl v >>=? fun v -> return (L v) | Union_t _, Prim (loc, "Left", l) -> fail @@ Invalid_arity (loc, "Left", 1, List.length l) | Union_t (_, tr), Prim (_, "Right", [ v ]) -> traced @@ parse_data ctxt tr v >>=? fun v -> return (R v) | Union_t _, Prim (loc, "Right", l) -> fail @@ Invalid_arity (loc, "Right", 1, List.length l) | Union_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Left" ; "Right" ])) (* Lambdas *) | Lambda_t (ta, tr), (Seq _ as script_instr) -> traced @@ parse_lambda ctxt ta tr script_instr | Lambda_t _, expr -> traced (fail (Invalid_kind (location expr, [ Seq_kind ], kind expr))) (* Options *) | Option_t t, Prim (_, "Some", [ v ]) -> traced @@ parse_data ctxt t v >>=? fun v -> return (Some v) | Option_t _, Prim (loc, "Some", l) -> fail @@ Invalid_arity (loc, "Some", 1, List.length l) | Option_t _, Prim (_, "None", []) -> return None | Option_t _, Prim (loc, "None", l) -> fail @@ Invalid_arity (loc, "None", 0, List.length l) | Option_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Some" ; "None" ])) (* Lists *) | List_t t, Prim (_, "List", vs) -> traced @@ fold_left_s (fun rest v -> parse_data ctxt t v >>=? fun v -> return (v :: rest)) [] vs | List_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "List" ])) (* Sets *) | Set_t t, Prim (_, "Set", vs) -> traced @@ fold_left_s (fun acc v -> parse_comparable_data ctxt t v >>=? fun v -> return (set_update v true acc)) (empty_set t) vs | Set_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Set" ])) (* Maps *) | Map_t (tk, tv), Prim (_, "Map", vs) -> traced @@ fold_left_s (fun acc -> function | Prim (_, "Item", [ k; v ]) -> parse_comparable_data ctxt tk k >>=? fun k -> parse_data ctxt tv v >>=? fun v -> return (map_update k (Some v) acc) | Prim (loc, "Item", l) -> fail @@ Invalid_arity (loc, "Item", 2, List.length l) | Prim (loc, name, _) -> fail @@ Invalid_primitive (loc, [ "Item" ], name) | Int _ | String _ | Seq _ -> fail (error ())) (empty_map tk) vs | Map_t _, expr -> traced (fail (unexpected expr [] Constant_namespace [ "Map" ])) and parse_comparable_data : type a. context -> a comparable_ty -> Script.expr -> a tzresult Lwt.t = fun ctxt ty script_data -> parse_data ctxt (ty_of_comparable_ty ty) script_data and parse_lambda : type arg ret storage. context -> ?storage_type: storage ty -> arg ty -> ret ty -> Script.expr -> (arg, ret) lambda tzresult Lwt.t = fun ctxt ?storage_type arg ret script_instr -> parse_instr ctxt ?storage_type script_instr (Item_t (arg, Empty_t)) >>=? function | Typed ({ loc ; aft = (Item_t (ty, Empty_t) as stack_ty) } as descr) -> trace (Bad_return (loc, stack_ty, ret)) (Lwt.return (ty_eq ty ret)) >>=? fun (Eq _) -> return (Lam (descr, script_instr) : (arg, ret) lambda) | Typed { loc ; aft = stack_ty } -> fail (Bad_return (loc, stack_ty, ret)) | Failed { descr } -> return (Lam (descr (Item_t (ret, Empty_t)), script_instr) : (arg, ret) lambda) and parse_instr : type bef storage. context -> ?storage_type: storage ty -> Script.expr -> bef stack_ty -> bef judgement tzresult Lwt.t = fun ctxt ?storage_type script_instr stack_ty -> let return : bef judgement -> bef judgement tzresult Lwt.t = return in let check_item check loc name n m = trace (Bad_stack (loc, name, m, stack_ty)) @@ trace (Bad_stack_item n) @@ Lwt.return check in let check_item_ty exp got loc n = check_item (ty_eq exp got) loc n in let typed loc (instr, aft) = Typed { loc ; instr ; bef = stack_ty ; aft } in match script_instr, stack_ty with (* stack ops *) | Prim (loc, "DROP", []), Item_t (_, rest) -> return (typed loc (Drop, rest)) | Prim (loc, "DUP", []), Item_t (v, rest) -> return (typed loc (Dup, Item_t (v, Item_t (v, rest)))) | Prim (loc, "SWAP", []), Item_t (v, Item_t (w, rest)) -> return (typed loc (Swap, Item_t (w, Item_t (v, rest)))) | Prim (loc, "PUSH", [ t ; d ]), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> parse_data ctxt t d >>=? fun v -> return (typed loc (Const v, Item_t (t, stack))) | Prim (loc, "UNIT", []), stack -> return (typed loc (Const (), Item_t (Unit_t, stack))) (* options *) | Prim (loc, "SOME", []), Item_t (t, rest) -> return (typed loc (Cons_some, Item_t (Option_t t, rest))) | Prim (loc, "NONE", [ t ]), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> return (typed loc (Cons_none t, Item_t (Option_t t, stack))) | Prim (loc, "IF_NONE", [ bt ; bf ]), (Item_t (Option_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ctxt bt rest >>=? fun btr -> parse_instr ?storage_type ctxt bf (Item_t (t, rest)) >>=? fun bfr -> let branch ibt ibf = { loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } (* pairs *) | Prim (loc, "PAIR", []), Item_t (a, Item_t (b, rest)) -> return (typed loc (Cons_pair, Item_t (Pair_t(a, b), rest))) | Prim (loc, "CAR", []), Item_t (Pair_t (a, _), rest) -> return (typed loc (Car, Item_t (a, rest))) | Prim (loc, "CDR", []), Item_t (Pair_t (_, b), rest) -> return (typed loc (Cdr, Item_t (b, rest))) (* unions *) | Prim (loc, "LEFT", [ tr ]), Item_t (tl, rest) -> (Lwt.return (parse_ty tr)) >>=? fun (Ex_ty tr) -> return (typed loc (Left, Item_t (Union_t (tl, tr), rest))) | Prim (loc, "RIGHT", [ tl ]), Item_t (tr, rest) -> (Lwt.return (parse_ty tl)) >>=? fun (Ex_ty tl) -> return (typed loc (Right, Item_t (Union_t (tl, tr), rest))) | Prim (loc, "IF_LEFT", [ bt ; bf ]), (Item_t (Union_t (tl, tr), rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ctxt bt (Item_t (tl, rest)) >>=? fun btr -> parse_instr ?storage_type ctxt bf (Item_t (tr, rest)) >>=? fun bfr -> let branch ibt ibf = { loc ; instr = If_left (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } (* lists *) | Prim (loc, "NIL", [ t ]), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty t) -> return (typed loc (Nil, Item_t (List_t t, stack))) | Prim (loc, "CONS", []), Item_t (tv, Item_t (List_t t, rest)) -> check_item_ty tv t loc "CONS" 1 2 >>=? fun (Eq _) -> return (typed loc (Cons_list, Item_t (List_t t, rest))) | Prim (loc, "IF_CONS", [ bt ; bf ]), (Item_t (List_t t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ctxt bt (Item_t (t, Item_t (List_t t, rest))) >>=? fun btr -> parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> let branch ibt ibf = { loc ; instr = If_cons (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } | Prim (loc, "MAP", []), Item_t (Lambda_t (param, ret), Item_t (List_t elt, rest)) -> check_item_ty elt param loc "MAP" 2 2 >>=? fun (Eq _) -> return (typed loc (List_map, Item_t (List_t ret, rest))) | Prim (loc, "REDUCE", []), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (List_t elt, Item_t (init, rest))) -> check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> return (typed loc (List_reduce, Item_t (r, rest))) (* sets *) | Prim (loc, "EMPTY_SET", [ t ]), rest -> (Lwt.return (parse_comparable_ty t)) >>=? fun (Ex_comparable_ty t) -> return (typed loc (Empty_set t, Item_t (Set_t t, rest))) | Prim (loc, "MAP", []), Item_t (Lambda_t (param, ret), Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in (Lwt.return (comparable_ty_of_ty loc ret)) >>=? fun ret -> check_item_ty elt param loc "MAP" 1 2 >>=? fun (Eq _) -> return (typed loc (Set_map ret, Item_t (Set_t ret, rest))) | Prim (loc, "REDUCE", []), Item_t (Lambda_t (Pair_t (pelt, pr), r), Item_t (Set_t elt, Item_t (init, rest))) -> let elt = ty_of_comparable_ty elt in check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty elt pelt loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> return (typed loc (Set_reduce, Item_t (r, rest))) | Prim (loc, "MEM", []), Item_t (v, Item_t (Set_t elt, rest)) -> let elt = ty_of_comparable_ty elt in check_item_ty elt v loc "MEM" 1 2 >>=? fun (Eq _) -> return (typed loc (Set_mem, Item_t (Bool_t, rest))) | Prim (loc, "UPDATE", []), Item_t (v, Item_t (Bool_t, Item_t (Set_t elt, rest))) -> let ty = ty_of_comparable_ty elt in check_item_ty ty v loc "UPDATE" 1 3 >>=? fun (Eq _) -> return (typed loc (Set_update, Item_t (Set_t elt, rest))) (* maps *) | Prim (loc, "EMPTY_MAP", [ tk ; tv ]), stack -> (Lwt.return (parse_comparable_ty tk)) >>=? fun (Ex_comparable_ty tk) -> (Lwt.return (parse_ty tv)) >>=? fun (Ex_ty tv) -> return (typed loc (Empty_map (tk, tv), Item_t (Map_t (tk, tv), stack))) | Prim (loc, "MAP", []), Item_t (Lambda_t (Pair_t (pk, pv), ret), Item_t (Map_t (ck, v), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty pk k loc "MAP" 1 2 >>=? fun (Eq _) -> check_item_ty pv v loc "MAP" 1 2 >>=? fun (Eq _) -> return (typed loc (Map_map, Item_t (Map_t (ck, ret), rest))) | Prim (loc, "REDUCE", []), Item_t (Lambda_t (Pair_t (Pair_t (pk, pv), pr), r), Item_t (Map_t (ck, v), Item_t (init, rest))) -> let k = ty_of_comparable_ty ck in check_item_ty pk k loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty pv v loc "REDUCE" 2 3 >>=? fun (Eq _) -> check_item_ty r pr loc "REDUCE" 1 3 >>=? fun (Eq _) -> check_item_ty init r loc "REDUCE" 3 3 >>=? fun (Eq _) -> return (typed loc (Map_reduce, Item_t (r, rest))) | Prim (loc, "MEM", []), Item_t (vk, Item_t (Map_t (ck, _), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "MEM" 1 2 >>=? fun (Eq _) -> return (typed loc (Map_mem, Item_t (Bool_t, rest))) | Prim (loc, "GET", []), Item_t (vk, Item_t (Map_t (ck, elt), rest)) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "GET" 1 2 >>=? fun (Eq _) -> return (typed loc (Map_get, Item_t (Option_t elt, rest))) | Prim (loc, "UPDATE", []), Item_t (vk, Item_t (Option_t vv, Item_t (Map_t (ck, v), rest))) -> let k = ty_of_comparable_ty ck in check_item_ty vk k loc "UPDATE" 1 3 >>=? fun (Eq _) -> check_item_ty vv v loc "UPDATE" 2 3 >>=? fun (Eq _) -> return (typed loc (Map_update, Item_t (Map_t (ck, v), rest))) (* control *) | Seq (loc, []), stack -> return (typed loc (Nop, stack)) | Seq (_, [ single ]), stack -> parse_instr ?storage_type ctxt single stack | Seq (loc, hd :: tl), stack -> parse_instr ?storage_type ctxt hd stack >>=? begin function | Failed _ -> fail (Fail_not_in_tail_position loc) | Typed ({ aft = middle } as ihd) -> parse_instr ?storage_type ctxt (Seq (loc, tl)) middle >>=? function | Failed { descr } -> let descr ret = { loc ; instr = Seq (ihd, descr ret) ; bef = stack ; aft = ret } in return (Failed { descr }) | Typed itl -> return (typed loc (Seq (ihd, itl), itl.aft)) end | Prim (loc, "IF", [ bt ; bf ]), (Item_t (Bool_t, rest) as bef) -> check_kind [ Seq_kind ] bt >>=? fun () -> check_kind [ Seq_kind ] bf >>=? fun () -> parse_instr ?storage_type ctxt bt rest >>=? fun btr -> parse_instr ?storage_type ctxt bf rest >>=? fun bfr -> let branch ibt ibf = { loc ; instr = If (ibt, ibf) ; bef ; aft = ibt.aft } in merge_branches loc btr bfr { branch } | Prim (loc, "LOOP", [ body ]), (Item_t (Bool_t, rest) as stack) -> check_kind [ Seq_kind ] body >>=? fun () -> parse_instr ?storage_type ctxt body rest >>=? begin function | Typed ibody -> trace (Unmatched_branches (loc, ibody.aft, stack)) (Lwt.return (stack_ty_eq 1 ibody.aft stack)) >>=? fun (Eq _) -> return (typed loc (Loop ibody, rest)) | Failed { descr } -> let ibody = descr (Item_t (Bool_t, rest)) in return (typed loc (Loop ibody, rest)) end | Prim (loc, "LAMBDA", [ arg ; ret ; code ]), stack -> (Lwt.return (parse_ty arg)) >>=? fun (Ex_ty arg) -> (Lwt.return (parse_ty ret)) >>=? fun (Ex_ty ret) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_lambda ctxt arg ret code >>=? fun lambda -> return (typed loc (Lambda lambda, Item_t (Lambda_t (arg, ret), stack))) | Prim (loc, "EXEC", []), Item_t (arg, Item_t (Lambda_t (param, ret), rest)) -> check_item_ty arg param loc "EXEC" 1 2 >>=? fun (Eq _) -> return (typed loc (Exec, Item_t (ret, rest))) | Prim (loc, "DIP", [ code ]), Item_t (v, rest) -> check_kind [ Seq_kind ] code >>=? fun () -> parse_instr ctxt code rest >>=? begin function | Typed descr -> return (typed loc (Dip descr, Item_t (v, descr.aft))) | Failed _ -> fail (Fail_not_in_tail_position loc) end | Prim (loc, "FAIL", []), bef -> let descr aft = { loc ; instr = Fail ; bef ; aft } in return (Failed { descr }) | Prim (loc, "NOP", []), stack -> return (typed loc (Nop, stack)) (* timestamp operations *) | Prim (loc, "ADD", []), Item_t (Timestamp_t, Item_t (Int_t kind, rest)) -> check_item (unsigned_int_kind kind) loc "ADD" 2 2 >>=? fun (Eq _) -> return (typed loc (Add_timestamp_to_seconds kind, Item_t (Timestamp_t, rest))) | Prim (loc, "ADD", []), Item_t (Int_t kind, Item_t (Timestamp_t, rest)) -> check_item (unsigned_int_kind kind) loc "ADD" 1 2 >>=? fun (Eq _) -> return (typed loc (Add_seconds_to_timestamp kind, Item_t (Timestamp_t, rest))) (* string operations *) | Prim (loc, "CONCAT", []), Item_t (String_t, Item_t (String_t, rest)) -> return (typed loc (Concat, Item_t (String_t, rest))) (* currency operations *) | Prim (loc, "ADD", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc (Add_tez, Item_t (Tez_t, rest))) | Prim (loc, "SUB", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc (Sub_tez, Item_t (Tez_t, rest))) | Prim (loc, "MUL", []), Item_t (Tez_t, Item_t (Int_t kind, rest)) -> check_item (unsigned_int_kind kind) loc "MUL" 2 2 >>=? fun (Eq _) -> return (typed loc (Mul_tez kind, Item_t (Tez_t, rest))) | Prim (loc, "MUL", []), Item_t (Int_t kind, Item_t (Tez_t, rest)) -> check_item (unsigned_int_kind kind) loc "MUL" 1 2 >>=? fun (Eq _) -> return (typed loc (Mul_tez' kind, Item_t (Tez_t, rest))) (* boolean operations *) | Prim (loc, "OR", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc (Or, Item_t (Bool_t, rest))) | Prim (loc, "AND", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc (And, Item_t (Bool_t, rest))) | Prim (loc, "XOR", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc (Xor, Item_t (Bool_t, rest))) | Prim (loc, "NOT", []), Item_t (Bool_t, rest) -> return (typed loc (Not, Item_t (Bool_t, rest))) (* integer operations *) | Prim (loc, "CHECKED_ABS", []), Item_t (Int_t k, rest) -> check_item (signed_int_kind k) loc "CHECKED_ABS" 1 1 >>=? fun (Eq _) -> return (typed loc (Checked_abs_int k, Item_t (Int_t k, rest))) | Prim (loc, "CHECKED_NEG", []), Item_t (Int_t k, rest) -> check_item (signed_int_kind k) loc "CHECKED_NEG" 1 1 >>=? fun (Eq _) -> return (typed loc (Checked_neg_int k, Item_t (Int_t k, rest))) | Prim (loc, "CHECKED_ADD", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "CHECKED_ADD" 1 2 >>=? fun (Eq _) -> return (typed loc (Checked_add_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "CHECKED_SUB", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "CHECKED_SUB" 1 2 >>=? fun (Eq _) -> return (typed loc (Checked_sub_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "CHECKED_MUL", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "CHECKED_MUL" 1 2 >>=? fun (Eq _) -> return (typed loc (Checked_mul_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "ABS", []), Item_t (Int_t k, rest) -> check_item (signed_int_kind k) loc "ABS" 1 1 >>=? fun (Eq _) -> return (typed loc (Abs_int k, Item_t (Int_t k, rest))) | Prim (loc, "NEG", []), Item_t (Int_t k, rest) -> check_item (signed_int_kind k) loc "NEG" 1 1 >>=? fun (Eq _) -> return (typed loc (Neg_int k, Item_t (Int_t k, rest))) | Prim (loc, "ADD", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "ADD" 1 2 >>=? fun (Eq _) -> return (typed loc (Add_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "SUB", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "SUB" 1 2 >>=? fun (Eq _) -> return (typed loc (Sub_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "MUL", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "MUL" 1 2 >>=? fun (Eq _) -> return (typed loc (Mul_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "DIV", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "DIV" 1 2 >>=? fun (Eq _) -> return (typed loc (Div_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "MOD", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "MOD" 1 2 >>=? fun (Eq _) -> return (typed loc (Mod_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "LSL", []), Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> check_item (unsigned_int_kind k) loc "LSL" 1 2 >>=? fun (Eq _) -> return (typed loc (Lsl_int k, Item_t (Int_t k, rest))) | Prim (loc, "LSR", []), Item_t (Int_t k, Item_t (Int_t Uint8, rest)) -> check_item (unsigned_int_kind k) loc "LSR" 1 2 >>=? fun (Eq _) -> return (typed loc (Lsr_int k, Item_t (Int_t k, rest))) | Prim (loc, "OR", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (unsigned_int_kind kl) loc "OR" 1 2 >>=? fun (Eq _) -> check_item (int_kind_eq kl kr) loc "OR" 1 2 >>=? fun (Eq _) -> return (typed loc (Or_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "AND", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (unsigned_int_kind kl) loc "AND" 1 2 >>=? fun (Eq _) -> check_item (int_kind_eq kl kr) loc "AND" 1 2 >>=? fun (Eq _) -> return (typed loc (And_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "XOR", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (unsigned_int_kind kl) loc "XOR" 1 2 >>=? fun (Eq _) -> check_item (int_kind_eq kl kr) loc "XOR" 1 2 >>=? fun (Eq _) -> return (typed loc (Xor_int kl, Item_t (Int_t kl, rest))) | Prim (loc, "NOT", []), Item_t (Int_t k, rest) -> check_item (unsigned_int_kind k) loc "NOT" 1 1 >>=? fun (Eq _) -> return (typed loc (Not_int k, Item_t (Int_t k, rest))) (* comparison *) | Prim (loc, "COMPARE", []), Item_t (Int_t kl, Item_t (Int_t kr, rest)) -> check_item (int_kind_eq kl kr) loc "COMPARE" 1 2 >>=? fun (Eq _) -> return (typed loc (Compare (Int_key kl), Item_t (Int_t Int64, rest))) | Prim (loc, "COMPARE", []), Item_t (Bool_t, Item_t (Bool_t, rest)) -> return (typed loc (Compare Bool_key, Item_t (Int_t Int64, rest))) | Prim (loc, "COMPARE", []), Item_t (String_t, Item_t (String_t, rest)) -> return (typed loc (Compare String_key, Item_t (Int_t Int64, rest))) | Prim (loc, "COMPARE", []), Item_t (Tez_t, Item_t (Tez_t, rest)) -> return (typed loc (Compare Tez_key, Item_t (Int_t Int64, rest))) | Prim (loc, "COMPARE", []), Item_t (Key_t, Item_t (Key_t, rest)) -> return (typed loc (Compare Key_key, Item_t (Int_t Int64, rest))) | Prim (loc, "COMPARE", []), Item_t (Timestamp_t, Item_t (Timestamp_t, rest)) -> return (typed loc (Compare Timestamp_key, Item_t (Int_t Int64, rest))) (* comparators *) | Prim (loc, "EQ", []), Item_t (Int_t Int64, rest) -> return (typed loc (Eq, Item_t (Bool_t, rest))) | Prim (loc, "NEQ", []), Item_t (Int_t Int64, rest) -> return (typed loc (Neq, Item_t (Bool_t, rest))) | Prim (loc, "LT", []), Item_t (Int_t Int64, rest) -> return (typed loc (Lt, Item_t (Bool_t, rest))) | Prim (loc, "GT", []), Item_t (Int_t Int64, rest) -> return (typed loc (Gt, Item_t (Bool_t, rest))) | Prim (loc, "LE", []), Item_t (Int_t Int64, rest) -> return (typed loc (Le, Item_t (Bool_t, rest))) | Prim (loc, "GE", []), Item_t (Int_t Int64, rest) -> return (typed loc (Ge, Item_t (Bool_t, rest))) (* casts *) | Prim (loc, "CHECKED_CAST", [ t ]), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty ty) -> begin match ty, stack with | Int_t kt, Item_t (Int_t kf, rest) -> return (typed loc (Checked_int_of_int (kf, kt), Item_t (Int_t kt, rest))) | ty, Item_t (ty', _) -> fail (Undefined_cast (loc, ty', ty)) | _, Empty_t -> fail (Bad_stack (loc, "CHECKED_CAST", 1, stack)) end | Prim (loc, "CAST", [ t ]), stack -> (Lwt.return (parse_ty t)) >>=? fun (Ex_ty ty) -> begin match ty, stack with | Int_t kt, Item_t (Int_t kf, rest) -> return (typed loc (Int_of_int (kf, kt), Item_t (Int_t kt, rest))) | ty, Item_t (ty', _) -> fail (Undefined_cast (loc, ty', ty)) | _, Empty_t -> fail (Bad_stack (loc, "CAST", 1, stack)) end (* protocol *) | Prim (loc, "MANAGER", []), Item_t (Contract_t _, rest) -> return (typed loc (Manager, Item_t (Key_t, rest))) | Prim (loc, "TRANSFER_TOKENS", []), Item_t (p, Item_t (Tez_t, Item_t (Contract_t (cp, cr), Item_t (storage, Empty_t)))) -> check_item_ty p cp loc "TRANSFER_TOKENS" 1 4 >>=? fun (Eq _) -> begin match storage_type with | Some storage_type -> check_item_ty storage storage_type loc "TRANSFER_TOKENS" 3 4 >>=? fun (Eq _) -> return (typed loc (Transfer_tokens storage, Item_t (cr, Item_t (storage, Empty_t)))) | None -> fail (Transfer_in_lambda loc) end | Prim (loc, "CREATE_ACCOUNT", []), Item_t (Key_t, Item_t (Option_t Key_t, Item_t (Bool_t, Item_t (Tez_t, rest)))) -> return (typed loc (Create_account, Item_t (Contract_t (Unit_t, Unit_t), rest))) | Prim (loc, "CREATE_CONTRACT", []), Item_t (Key_t, Item_t (Option_t Key_t, Item_t (Bool_t, Item_t (Tez_t, Item_t (Lambda_t (Pair_t (Pair_t (Tez_t, p), gp), Pair_t (r, gr)), Item_t (ginit, rest)))))) -> check_item_ty gp gr loc "CREATE_CONTRACT" 5 6 >>=? fun (Eq _) -> check_item_ty ginit gp loc "CREATE_CONTRACT" 6 6 >>=? fun (Eq _) -> return (typed loc (Create_contract (gp, p, r), Item_t (Contract_t (p, r), rest))) | Prim (loc, "NOW", []), stack -> return (typed loc (Now, Item_t (Timestamp_t, stack))) | Prim (loc, "AMOUNT", []), stack -> return (typed loc (Amount, Item_t (Tez_t, stack))) | Prim (loc, "BALANCE", []), stack -> return (typed loc (Balance, Item_t (Tez_t, stack))) | Prim (loc, "CHECK_SIGNATURE", []), Item_t (Key_t, Item_t (Pair_t (Signature_t, String_t), rest)) -> return (typed loc (Check_signature, Item_t (Bool_t, rest))) | Prim (loc, "H", []), Item_t (t, rest) -> return (typed loc (H t, Item_t (String_t, rest))) | Prim (loc, "STEPS_TO_QUOTA", []), stack -> return (typed loc (Steps_to_quota, Item_t (Int_t Uint32, stack))) | Prim (loc, "SOURCE", [ ta; tb ]), stack -> (Lwt.return (parse_ty ta)) >>=? fun (Ex_ty ta) -> (Lwt.return (parse_ty tb)) >>=? fun (Ex_ty tb) -> return (typed loc (Source (ta, tb), Item_t (Contract_t (ta, tb), stack))) (* Primitive parsing errors *) | Prim (loc, ("DROP" | "DUP" | "SWAP" | "SOME" | "UNIT" | "PAIR" | "CAR" | "CDR" | "CONS" | "MEM" | "UPDATE" | "MAP" | "REDUCE" | "GET" | "EXEC" | "FAIL" | "NOP" | "CONCAT" | "ADD" | "SUB" | "MUL" | "DIV" | "MOD" | "OR" | "AND" | "XOR" | "NOT" | "CHECKED_ABS" | "CHECKED_NEG" | "CHECKED_ADD" | "CHECKED_SUB" | "CHECKED_MUL" | "ABS" | "NEG" | "LSL" | "LSR" | "COMPARE" | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" | "MANAGER" | "TRANSFER_TOKENS" | "CREATE_ACCOUNT" | "CREATE_CONTRACT" | "NOW" | "AMOUNT" | "BALANCE" | "CHECK_SIGNATURE" | "H" | "STEPS_TO_QUOTA" as name), (_ :: _ as l)), _ -> fail (Invalid_arity (loc, name, 0, List.length l)) | Prim (loc, ("NONE" | "LEFT" | "RIGHT" | "NIL" | "EMPTY_SET" | "DIP" | "CHECKED_CAST" | "CAST" | "LOOP" as name), ([] | _ :: _ :: _ as l)), _ -> fail (Invalid_arity (loc, name, 1, List.length l)) | Prim (loc, ("PUSH" | "IF_NONE" | "IF_LEFT" | "IF_CONS" | "EMPTY_MAP" | "IF" | "SOURCE" as name), ([] | [ _ ] | _ :: _ :: _ :: _ as l)), _ -> fail (Invalid_arity (loc, name, 2, List.length l)) | Prim (loc, "LAMBDA", ([] | [ _ ] | [ _ ; _ ] | _ :: _ :: _ :: _ :: _ as l)), _ -> fail (Invalid_arity (loc, "LAMBDA", 3, List.length l)) (* Stack errors *) | Prim (loc, ("ADD" | "SUB" | "MUL" | "DIV" | "MOD" | "AND" | "OR" | "XOR" | "LSL" | "LSR" | "CONCAT" | "COMPARE" | "CHECKED_ABS" | "CHECKED_NEG" | "CHECKED_ADD" | "CHECKED_SUB" | "CHECKED_MUL" as name), []), Item_t (ta, Item_t (tb, _)) -> fail (Undefined_binop (loc, name, ta, tb)) | Prim (loc, ("NEG" | "ABS" | "NOT" | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), []), Item_t (t, _) -> fail (Undefined_unop (loc, name, t)) | Prim (loc, ("REDUCE" | "UPDATE" as name), []), stack -> fail (Bad_stack (loc, name, 3, stack)) | Prim (loc, "CREATE_CONTRACT", []), stack -> fail (Bad_stack (loc, "CREATE_CONTRACT", 6, stack)) | Prim (loc, "CREATE_ACCOUNT", []), stack -> fail (Bad_stack (loc, "CREATE_ACCOUNT", 4, stack)) | Prim (loc, "TRANSFER_TOKENS", []), stack -> fail (Bad_stack (loc, "TRANSFER_TOKENS", 3, stack)) | Prim (loc, ("DROP" | "DUP" | "CAR" | "CDR" | "SOME" | "H" | "DIP" | "IF_NONE" | "LEFT" | "RIGHT" | "IF_LEFT" | "IF" | "LOOP" | "IF_CONS" | "MANAGER" | "NEG" | "ABS" | "NOT" | "EQ" | "NEQ" | "LT" | "GT" | "LE" | "GE" as name), _), stack -> fail (Bad_stack (loc, name, 1, stack)) | Prim (loc, ("SWAP" | "PAIR" | "CONS" | "MAP" | "GET" | "MEM" | "EXEC" | "CHECK_SIGNATURE" | "ADD" | "SUB" | "MUL" | "DIV" | "MOD" | "AND" | "OR" | "XOR" | "LSL" | "LSR" | "CONCAT" | "CHECKED_ABS" | "CHECKED_NEG" | "CHECKED_ADD" | "CHECKED_SUB" | "CHECKED_MUL" | "COMPARE" as name), _), stack -> fail (Bad_stack (loc, name, 2, stack)) (* Generic parsing errors *) | expr, _ -> fail @@ unexpected expr [ Seq_kind ] Instr_namespace [ "DROP" ; "DUP" ; "SWAP" ; "SOME" ; "UNIT" ; "PAIR" ; "CAR" ; "CDR" ; "CONS" ; "MEM" ; "UPDATE" ; "MAP" ; "REDUCE" ; "GET" ; "EXEC" ; "FAIL" ; "NOP" ; "CONCAT" ; "ADD" ; "SUB" ; "MUL" ; "DIV" ; "MOD" ; "OR" ; "AND" ; "XOR" ; "NOT" ; "CHECKED_ABS" ; "CHECKED_NEG" ; "CHECKED_ADD" ; "CHECKED_SUB" ; "CHECKED_MUL" ; "ABS" ; "NEG" ; "LSL" ; "LSR" ; "COMPARE" ; "EQ" ; "NEQ" ; "LT" ; "GT" ; "LE" ; "GE" ; "MANAGER" ; "TRANSFER_TOKENS" ; "CREATE_ACCOUNT" ; "CREATE_CONTRACT" ; "NOW" ; "AMOUNT" ; "BALANCE" ; "CHECK_SIGNATURE" ; "H" ; "STEPS_TO_QUOTA" ; "PUSH" ; "NONE" ; "LEFT" ; "RIGHT" ; "NIL" ; "EMPTY_SET" ; "DIP" ; "CHECKED_CAST" ; "CAST" ; "LOOP" ; "IF_NONE" ; "IF_LEFT" ; "IF_CONS" ; "EMPTY_MAP" ; "IF" ; "SOURCE" ; "LAMBDA" ] and parse_contract : type arg ret. context -> arg ty -> ret ty -> Script.location -> Contract.t -> (arg, ret) typed_contract tzresult Lwt.t = fun ctxt arg ret loc contract -> Contract.exists ctxt contract >>=? function | false -> fail (Invalid_contract (loc, contract)) | true -> trace (Invalid_contract (loc, contract)) @@ Contract.get_script ctxt contract >>=? function | None -> Lwt.return (ty_eq arg Unit_t >>? fun (Eq _) -> ty_eq ret Unit_t >>? fun (Eq _) -> let contract : (arg, ret) typed_contract = (arg, ret, contract) in ok contract) | Some { code = { arg_type; ret_type} } -> Lwt.return (parse_ty arg_type >>? fun (Ex_ty targ) -> parse_ty ret_type >>? fun (Ex_ty tret) -> ty_eq targ arg >>? fun (Eq _) -> ty_eq tret ret >>? fun (Eq _) -> let contract : (arg, ret) typed_contract = (arg, ret, contract) in ok contract) type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script let parse_script : context -> Script.storage -> Script.code -> ex_script tzresult Lwt.t = fun ctxt { storage; storage_type } { code; arg_type; ret_type } -> (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in parse_data ctxt storage_type storage >>=? fun storage -> parse_lambda ctxt ~storage_type arg_type_full ret_type_full code >>=? fun code -> return (Ex_script { code; arg_type; ret_type; storage; storage_type }) type type_map = (int * (Script.expr list * Script.expr list)) list let type_map_enc = let open Data_encoding in list (tup2 int31 (tup2 (list Script.expr_encoding) (list Script.expr_encoding))) let type_map descr = let rec unparse_stack : type a. a stack_ty -> Script.expr list = function | Empty_t -> [] | Item_t (ty, rest) -> unparse_ty ty :: unparse_stack rest in let rec type_map : type bef aft. type_map -> (bef, aft) descr -> type_map = fun acc { loc ; instr ; bef ; aft } -> let self acc = (loc, (unparse_stack bef, unparse_stack aft)) :: acc in match instr with | If_none (dbt, dbf) -> let acc = type_map acc dbt in let acc = type_map acc dbf in self acc | If_left (dbt, dbf) -> let acc = type_map acc dbt in let acc = type_map acc dbf in self acc | If_cons (dbt, dbf) -> let acc = type_map acc dbt in let acc = type_map acc dbf in self acc | Seq (dl, dr) -> let acc = type_map acc dl in let acc = type_map acc dr in acc | If (dbt, dbf) -> let acc = type_map acc dbt in let acc = type_map acc dbf in self acc | Loop body -> let acc = type_map acc body in self acc | Dip body -> let acc = type_map acc body in self acc | _ -> self acc in type_map [] descr let typecheck_code : context -> Script.code -> type_map tzresult Lwt.t = fun ctxt { code; arg_type; ret_type; storage_type } -> trace (Ill_formed_type (Some "parameter", arg_type)) (Lwt.return (parse_ty arg_type)) >>=? fun (Ex_ty arg_type) -> trace (Ill_formed_type (Some "return", ret_type)) (Lwt.return (parse_ty ret_type)) >>=? fun (Ex_ty ret_type) -> trace (Ill_formed_type (Some "storage", storage_type)) (Lwt.return (parse_ty storage_type)) >>=? fun (Ex_ty storage_type) -> let arg_type_full = Pair_t (Pair_t (Tez_t, arg_type), storage_type) in let ret_type_full = Pair_t (ret_type, storage_type) in trace (Ill_typed_contract (code, arg_type, ret_type, storage_type)) (parse_lambda ctxt ~storage_type arg_type_full ret_type_full code) >>=? fun (Lam (descr,_)) -> return (type_map descr) let typecheck_data : context -> Script.expr * Script.expr -> unit tzresult Lwt.t = fun ctxt (data, exp_ty) -> trace (Ill_formed_type (None, exp_ty)) (Lwt.return (parse_ty exp_ty)) >>=? fun (Ex_ty exp_ty) -> trace (Ill_typed_data (None, data, exp_ty)) (parse_data ctxt exp_ty data) >>=? fun _ -> return () (* ---- Error registration --------------------------------------------------*) let () = let open Data_encoding in let located enc = merge_objs (obj1 (req "location" Script.location_encoding)) enc in let arity_enc = int8 in let namespace_enc = def "primitiveNamespace" @@ describe ~title: "Primitive namespace" ~description: "One of the three possible namespaces of primitive \ (data constructor, type name or instruction)." @@ string_enum [ "type", Type_namespace ; "constant", Constant_namespace ; "instruction", Instr_namespace ] in let kind_enc = def "primitiveNamespace" @@ describe ~title: "Expression kind" ~description: "One of the four possible kinds of expression \ (integer, string, primitive application or sequence)." @@ string_enum [ "integer", Int_kind ; "string", String_kind ; "primitiveApplication", Prim_kind ; "sequence", Seq_kind ] in let ex_ty_enc = conv (fun (Ex_ty ty) -> unparse_ty ty) (fun expr -> match parse_ty expr with | Ok (Ex_ty ty) -> Ex_ty ty | _ -> Ex_ty Unit_t (* FIXME: ? *)) Script.expr_encoding in let ex_stack_ty_enc = let rec unfold = function | Ex_stack_ty (Item_t (ty, rest)) -> Ex_ty ty :: unfold (Ex_stack_ty rest) | Ex_stack_ty Empty_t -> [] in let rec fold = function | Ex_ty ty :: rest -> let Ex_stack_ty rest = fold rest in Ex_stack_ty (Item_t (ty, rest)) | [] -> Ex_stack_ty Empty_t in conv unfold fold (list ex_ty_enc) in (* -- Structure errors ---------------------- *) register_error_kind `Permanent ~id:"invalidArityTypeError" ~title: "Invalid arity (typechecking error)" ~description: "In a script or data expression, a primitive was applied \ to an unsupported number of arguments." (located (obj3 (req "primitiveName" string) (req "expectedArity" arity_enc) (req "wrongArity" arity_enc))) (function | Invalid_arity (loc, name, exp, got) -> Some (loc, (name, exp, got)) | _ -> None) (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ; register_error_kind `Permanent ~id:"invalidPrimitiveTypeError" ~title: "Invalid primitive (typechecking error)" ~description: "In a script or data expression, a primitive was unknown." (located (obj2 (dft "expectedPrimitiveNames" (list string) []) (req "wrongPrimitiveName" string))) (function | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ; register_error_kind `Permanent ~id:"invalidPrimitiveNameCaseTypeError" ~title: "Invalid primitive name case (typechecking error)" ~description: "In a script or data expression, a primitive name is \ neither uppercase, lowercase or capitalized." (located (obj1 (req "wrongPrimitiveName" string))) (function | Invalid_case (loc, name) -> Some (loc, name) | _ -> None) (fun (loc, name) -> Invalid_case (loc, name)) ; register_error_kind `Permanent ~id:"invalidExpressionKindTypeError" ~title: "Invalid expression kind (typechecking error)" ~description: "In a ascript or data expression, an expression was of the wrong kind \ (for instance a string where only a primitive applications can appear)." (located (obj2 (req "expectedKinds" (list kind_enc)) (req "wrongKind" kind_enc))) (function | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None) (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ; register_error_kind `Permanent ~id:"invalidPrimitiveNamespaceTypeError" ~title: "Invalid primitive namespace (typechecking error)" ~description: "In a ascript or data expression, a primitive was of the wrong namespace." (located (obj3 (req "primitiveName" string) (req "expectedNamespace" namespace_enc) (req "wrongNamespace" namespace_enc))) (function | Invalid_namespace (loc, name, exp, got) -> Some (loc, (name, exp, got)) | _ -> None) (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ; (* -- Instruction typing errors ------------- *) register_error_kind `Permanent ~id:"failNotInTailPositionTypeError" ~title: "FAIL not in tail position (typechecking error)" ~description: "There is non trivial garbage code after a FAIL instruction." (located empty) (function | Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None) (fun (loc, ()) -> Fail_not_in_tail_position loc) ; register_error_kind `Permanent ~id:"undefinedCastTypeError" ~title: "Undefined cast (typechecking error)" ~description: "A CAST operation is performed to or from an unsupported type." (located (obj2 (req "wrongInputType" ex_ty_enc) (req "wrongOutputType" ex_ty_enc))) (function | Undefined_cast (loc, tyl, tyr) -> Some (loc, (Ex_ty tyl, Ex_ty tyr)) | _ -> None) (fun (loc, (Ex_ty tyl, Ex_ty tyr)) -> Undefined_cast (loc, tyl, tyr)) ; register_error_kind `Permanent ~id:"undefinedBinopTypeError" ~title: "Undefined binop (typechecking error)" ~description: "A binary operation is called on operands of types \ over which it is not defined." (located (obj3 (req "operatorName" string) (req "wrongLeftOperandType" ex_ty_enc) (req "wrongRightOperandType" ex_ty_enc))) (function | Undefined_binop (loc, n, tyl, tyr) -> Some (loc, (n, Ex_ty tyl, Ex_ty tyr)) | _ -> None) (fun (loc, (n, Ex_ty tyl, Ex_ty tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ; register_error_kind `Permanent ~id:"undefinedUnopTypeError" ~title: "Undefined unop (typechecking error)" ~description: "A unary operation is called on an operand of type \ over which it is not defined." (located (obj2 (req "operatorName" string) (req "wrongOperandType" ex_ty_enc))) (function | Undefined_unop (loc, n, ty) -> Some (loc, (n, Ex_ty ty)) | _ -> None) (fun (loc, (n, Ex_ty ty)) -> Undefined_unop (loc, n, ty)) ; register_error_kind `Permanent ~id:"badReturnTypeError" ~title: "Bad return (typechecking error)" ~description: "Unexpected stack at the end of a lambda or script." (located (obj2 (req "expectedReturnType" ex_ty_enc) (req "wrongStackType" ex_stack_ty_enc))) (function | Bad_return (loc, sty, ty) -> Some (loc, (Ex_ty ty, Ex_stack_ty sty)) | _ -> None) (fun (loc, (Ex_ty ty, Ex_stack_ty sty)) -> Bad_return (loc, sty, ty)) ; register_error_kind `Permanent ~id:"badStackTypeError" ~title: "Bad stack (typechecking error)" ~description: "The stack has an unexpected length or contents." (located (obj3 (req "primitiveName" string) (req "relevantStackPortion" int16) (req "wrongStackType" ex_stack_ty_enc))) (function | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, Ex_stack_ty sty)) | _ -> None) (fun (loc, (name, s, Ex_stack_ty sty)) -> Bad_stack (loc, name, s, sty)) ; register_error_kind `Permanent ~id:"unmatchedBranchesTypeError" ~title: "Unmatched branches (typechecking error)" ~description: "At the join point at the end of two code branches \ the stacks have inconsistent lengths or contents." (located (obj2 (req "firstStackType" ex_stack_ty_enc) (req "otherStackType" ex_stack_ty_enc))) (function | Unmatched_branches (loc, stya, styb) -> Some (loc, (Ex_stack_ty stya, Ex_stack_ty styb)) | _ -> None) (fun (loc, (Ex_stack_ty stya, Ex_stack_ty styb)) -> Unmatched_branches (loc, stya, styb)) ; register_error_kind `Permanent ~id:"badStackItemTypeError" ~title: "Bad stack item (typechecking error)" ~description: "The type of a stack item is unexpected \ (this error is always accompanied by a more precise one)." (obj1 (req "itemLevel" int16)) (function | Bad_stack_item n -> Some n | _ -> None) (fun n -> Bad_stack_item n) ; register_error_kind `Permanent ~id:"TransferInLambdaTypeError" ~title: "Transfer in lambda (typechecking error)" ~description: "A TRANSFER_TOKENS instruction was encountered in a lambda expression." (located empty) (function | Transfer_in_lambda loc -> Some (loc, ()) | _ -> None) (fun (loc, ()) -> Transfer_in_lambda loc) ; register_error_kind `Permanent ~id:"inconsistentStackLengthsTypeError" ~title: "Inconsistent stack lengths (typechecking error)" ~description: "A stack was of an unexpected length \ (this error is always in the context of a located error)." empty (function | Bad_stack_length -> Some () | _ -> None) (fun () -> Bad_stack_length) ; (* -- Value typing errors ------------------- *) register_error_kind `Permanent ~id:"invalidConstantTypeError" ~title: "Invalid constant (typechecking error)" ~description: "A data expression was invalid for its expected type." (located (obj2 (req "expectedType" ex_ty_enc) (req "wrongExpression" Script.expr_encoding))) (function | Invalid_constant (loc, expr, ty) -> Some (loc, (Ex_ty ty, expr)) | _ -> None) (fun (loc, (Ex_ty ty, expr)) -> Invalid_constant (loc, expr, ty)) ; register_error_kind `Permanent ~id:"invalidContractTypeError" ~title: "Invalid contract (typechecking error)" ~description: "A script or data expression references a contract that does not \ exist or assumes a wrong type for an existing contract." (located (obj1 (req "contract" Contract.encoding))) (function | Invalid_contract (loc, c) -> Some (loc, c) | _ -> None) (fun (loc, c) -> Invalid_contract (loc, c)) ; register_error_kind `Permanent ~id:"comparableTypeExpectedTypeError" ~title: "Comparable type expected (typechecking error)" ~description: "A non comparable type was used in a place where \ only comparable types are accepted." (located (obj1 (req "wrongType" ex_ty_enc))) (function | Comparable_type_expected (loc, ty) -> Some (loc, Ex_ty ty) | _ -> None) (fun (loc, Ex_ty ty) -> Comparable_type_expected (loc, ty)) ; register_error_kind `Permanent ~id:"InconsistentTypesTypeError" ~title: "Inconsistent types (typechecking error)" ~description: "This is the basic type clash error, \ that appears in several places where the equality of \ two types have to be proven, it is always accompanied \ with another error that provides more context." (obj2 (req "firstType" ex_ty_enc) (req "otherType" ex_ty_enc)) (function | Inconsistent_types (tya, tyb) -> Some (Ex_ty tya, Ex_ty tyb) | _ -> None) (fun (Ex_ty tya, Ex_ty tyb) -> Inconsistent_types (tya, tyb)) ; register_error_kind `Permanent ~id:"badSignTypeError" ~title: "Bad sign (typechecking error)" ~description: "A signed (resp. unsigned) integer kind was used in a place \ where only unsigned (resp. signed) integers can be used, \ this error is always accompanied \ with another error that provides more context." (obj1 (req "wrongIntegerType" ex_ty_enc)) (function | Bad_sign ty -> Some (Ex_ty ty) | _ -> None) (fun (Ex_ty ty) -> Bad_sign ty) ; (* Toplevel errors *) register_error_kind `Permanent ~id:"illTypedDataTypeError" ~title: "Ill typed data (typechecking error)" ~description: "The toplevel error thrown when trying to typecheck \ a data expression against a given type \ (always followed by more precise errors)." (obj3 (opt "identifier" string) (req "expectedType" ex_ty_enc) (req "illTypedExpression" Script.expr_encoding)) (function | Ill_typed_data (name, expr, ty) -> Some (name, Ex_ty ty, expr) | _ -> None) (fun (name, Ex_ty ty, expr) -> Ill_typed_data (name, expr, ty)) ; (* type error += Ill_formed_type of string option * Script.expr *) register_error_kind `Permanent ~id:"illFormedTypeTypeError" ~title: "Ill formed type (typechecking error)" ~description: "The toplevel error thrown when trying to parse a type expression \ (always followed by more precise errors)." (obj2 (opt "identifier" string) (req "illFormedExpression" Script.expr_encoding)) (function | Ill_formed_type (name, expr) -> Some (name, expr) | _ -> None) (fun (name, expr) -> Ill_formed_type (name, expr)) ; register_error_kind `Permanent ~id:"illTypedContractTypeError" ~title: "Ill typed contract (typechecking error)" ~description: "The toplevel error thrown when trying to typecheck \ a contract code against given input, output and storage types \ (always followed by more precise errors)." (obj4 (req "expectedParameterType" ex_ty_enc) (req "expectedReturnType" ex_ty_enc) (req "expectedStorageType" ex_ty_enc) (req "illTypedExpression" Script.expr_encoding)) (function | Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty) -> Some (Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty, expr) | _ -> None) (fun (Ex_ty arg_ty, Ex_ty ret_ty, Ex_ty storage_ty, expr) -> Ill_typed_contract (expr, arg_ty, ret_ty, storage_ty))