Michelson: annotations for variable bindings with $
Also move annotation specific code to own module.
This commit is contained in:
Alain Mebsout
Benjamin Canou
parent
68f86fe274
commit
435d135aa0
@ -16,7 +16,7 @@ code { DUP; CAR;
|
||||
IF_LEFT { DUP; DIIP{ CDR %stored_balance; DUP };
|
||||
DIP{ SWAP }; GET;
|
||||
# Create the account
|
||||
IF_SOME @previous_balance
|
||||
IF_SOME $previous_balance
|
||||
# Add to an existing account
|
||||
{ AMOUNT; ADD; SOME; SWAP; UPDATE; NIL operation; PAIR }
|
||||
{ DIP{ AMOUNT; SOME }; UPDATE; NIL operation; PAIR }}
|
||||
@ -31,7 +31,7 @@ code { DUP; CAR;
|
||||
DIIP{ CDR %stored_balance; DUP };
|
||||
CAR %from; HASH_KEY @from_hash; DIP{ SWAP }; GET;
|
||||
# Account does not exist
|
||||
IF_NONE @previous_balance
|
||||
IF_NONE $previous_balance
|
||||
{ FAIL }
|
||||
# Account exists
|
||||
{ DUP; DIIP{ DUP; CDAR %withdraw_amount; DUP };
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
parameter (map int int);
|
||||
storage (pair int int);
|
||||
code { CAR; PUSH int 0; DUP; PAIR; SWAP;
|
||||
ITER { DIP {DUP; CAR; DIP{CDR}}; DUP; # Last instr
|
||||
parameter (map (int :k) (int :e));
|
||||
storage (pair (int :k) (int :e));
|
||||
code { CAR; PUSH @acc_e (int :e) 0; PUSH @acc_k (int :k) 0; PAIR; SWAP;
|
||||
ITER $my_key $my_elt
|
||||
{ DIP {DUP; CAR; DIP{CDR}}; DUP; # Last instr
|
||||
DIP{CAR; ADD}; SWAP; DIP{CDR; ADD}; PAIR };
|
||||
NIL operation; PAIR}
|
||||
|
||||
@ -12,6 +12,7 @@ open Alpha_context
|
||||
open Tezos_micheline
|
||||
open Script_typed_ir
|
||||
open Script_tc_errors
|
||||
open Script_ir_annot
|
||||
open Script_ir_translator
|
||||
open Script_interpreter
|
||||
open Michelson_v1_printer
|
||||
|
||||
@ -59,6 +59,7 @@
|
||||
"Fees",
|
||||
"Script_tc_errors",
|
||||
"Michelson_v1_gas",
|
||||
"Script_ir_annot",
|
||||
"Script_ir_translator",
|
||||
"Script_tc_errors_registration",
|
||||
"Script_interpreter",
|
||||
|
||||
359
src/proto_alpha/lib_protocol/src/script_ir_annot.ml
Normal file
359
src/proto_alpha/lib_protocol/src/script_ir_annot.ml
Normal file
@ -0,0 +1,359 @@
|
||||
(**************************************************************************)
|
||||
(* *)
|
||||
(* Copyright (c) 2014 - 2018. *)
|
||||
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||
(* *)
|
||||
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
open Alpha_context
|
||||
open Micheline
|
||||
open Script_tc_errors
|
||||
open Script_typed_ir
|
||||
|
||||
let default_now_annot = Some (`Var_annot "now")
|
||||
let default_amount_annot = Some (`Var_annot "amount")
|
||||
let default_balance_annot = Some (`Var_annot "balance")
|
||||
let default_steps_annot = Some (`Var_annot "steps")
|
||||
let default_source_annot = Some (`Var_annot "source")
|
||||
let default_self_annot = Some (`Var_annot "self")
|
||||
|
||||
let default_param_annot = Some (`Field_annot "parameter")
|
||||
let default_storage_annot = Some (`Field_annot "storage")
|
||||
let default_car_annot = Some (`Field_annot "car")
|
||||
let default_cdr_annot = Some (`Field_annot "cdr")
|
||||
let default_contract_annot = Some (`Field_annot "contract")
|
||||
let default_addr_annot = Some (`Field_annot "address")
|
||||
let default_manager_annot = Some (`Field_annot "manager")
|
||||
|
||||
let default_arg_annot = Some (`Binding_annot "arg")
|
||||
let default_elt_annot = Some (`Binding_annot "elt")
|
||||
let default_key_annot = Some (`Binding_annot "key")
|
||||
let default_hd_annot = Some (`Binding_annot "hd")
|
||||
let default_some_annot = Some (`Binding_annot "some")
|
||||
let default_left_annot = Some (`Binding_annot "left")
|
||||
let default_right_annot = Some (`Binding_annot "right")
|
||||
|
||||
let unparse_type_annot : type_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Type_annot a -> [ ":" ^ a ]
|
||||
|
||||
let unparse_var_annot : var_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Var_annot a -> [ "@" ^ a ]
|
||||
|
||||
let unparse_field_annot : field_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Field_annot a -> [ "%" ^ a ]
|
||||
|
||||
let unparse_binding_annot : binding_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Binding_annot a -> [ "$" ^ a ]
|
||||
|
||||
let field_to_var_annot : field_annot option -> var_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Field_annot s) -> Some (`Var_annot s)
|
||||
|
||||
let field_to_binding_annot : field_annot option -> binding_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Field_annot s) -> Some (`Binding_annot s)
|
||||
|
||||
let binding_to_var_annot : binding_annot option -> var_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Binding_annot s) -> Some (`Var_annot s)
|
||||
|
||||
let binding_to_field_annot : binding_annot option -> field_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Binding_annot s) -> Some (`Field_annot s)
|
||||
|
||||
let var_to_binding_annot : var_annot option -> binding_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Var_annot s) -> Some (`Binding_annot s)
|
||||
|
||||
let type_to_field_annot : type_annot option -> field_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Type_annot s) -> Some (`Field_annot s)
|
||||
|
||||
let var_to_field_annot : var_annot option -> field_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Var_annot s) -> Some (`Field_annot s)
|
||||
|
||||
let default_annot ~default = function
|
||||
| None -> default
|
||||
| annot -> annot
|
||||
|
||||
let gen_access_annot
|
||||
: var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option
|
||||
= fun value_annot ?(default=None) field_annot ->
|
||||
match value_annot, field_annot, default with
|
||||
| None, None, _ | Some _, None, None -> None
|
||||
| None, Some `Field_annot f, _ ->
|
||||
Some (`Var_annot f)
|
||||
| Some `Var_annot v, None, Some `Field_annot f ->
|
||||
Some (`Var_annot (String.concat "." [v; f]))
|
||||
| Some `Var_annot v, Some `Field_annot f, _ ->
|
||||
Some (`Var_annot (String.concat "." [v; f]))
|
||||
|
||||
let gen_binding_access_annot
|
||||
: var_annot option -> ?default:binding_annot option -> binding_annot option -> binding_annot option
|
||||
= fun value_annot ?(default=None) binding_annot ->
|
||||
match value_annot, binding_annot, default with
|
||||
| None, None, _ | Some _, None, None -> None
|
||||
| None, Some `Binding_annot b, _ ->
|
||||
Some (`Binding_annot b)
|
||||
| Some `Var_annot v, None, Some `Binding_annot b ->
|
||||
Some (`Binding_annot (String.concat "." [v; b]))
|
||||
| Some `Var_annot v, Some `Binding_annot b, _ ->
|
||||
Some (`Binding_annot (String.concat "." [v; b]))
|
||||
|
||||
let merge_type_annot
|
||||
: type_annot option -> type_annot option -> type_annot option tzresult
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> ok None
|
||||
| Some `Type_annot a1, Some `Type_annot a2 ->
|
||||
if String.equal a1 a2
|
||||
then ok annot1
|
||||
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
|
||||
|
||||
let merge_field_annot
|
||||
: field_annot option -> field_annot option -> field_annot option tzresult
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> ok None
|
||||
| Some `Field_annot a1, Some `Field_annot a2 ->
|
||||
if String.equal a1 a2
|
||||
then ok annot1
|
||||
else ok None (* TODO check this, do we want typechecking here ?
|
||||
error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) *)
|
||||
|
||||
let merge_var_annot
|
||||
: var_annot option -> var_annot option -> var_annot option
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> None
|
||||
| Some `Var_annot a1, Some `Var_annot a2 ->
|
||||
if String.equal a1 a2 then annot1 else None
|
||||
|
||||
let error_unexpected_annot loc annot =
|
||||
match annot with
|
||||
| [] -> ok ()
|
||||
| _ :: _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let fail_unexpected_annot loc annot =
|
||||
Lwt.return (error_unexpected_annot loc annot)
|
||||
|
||||
let parse_annots loc l =
|
||||
List.fold_left (fun acc s ->
|
||||
match acc with
|
||||
| Ok acc ->
|
||||
begin match s.[0] with
|
||||
| '@' -> ok (`Var_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| ':' -> ok (`Type_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| '%' -> ok (`Field_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| '$' -> ok (`Binding_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
| exception Invalid_argument _ -> error (Unexpected_annotation loc)
|
||||
end
|
||||
| Error _ -> acc
|
||||
) (ok []) l
|
||||
>|? List.rev
|
||||
|
||||
let parse_type_annot
|
||||
: int -> string list -> type_annot option tzresult
|
||||
= fun loc annot ->
|
||||
parse_annots loc annot >>? function
|
||||
| [] -> ok None
|
||||
| [ `Type_annot _ as a ] -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let parse_composed_type_annot
|
||||
: int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult
|
||||
= fun loc annot ->
|
||||
parse_annots loc annot >>? function
|
||||
| [] -> ok (None, None, None)
|
||||
| [ `Type_annot _ as a ] -> ok (Some a, None, None)
|
||||
| [ `Type_annot _ as a ; `Field_annot _ as b] -> ok (Some a, Some b, None)
|
||||
| [ `Type_annot _ as a ; `Field_annot _ as b; `Field_annot _ as c ] ->
|
||||
ok (Some a, Some b, Some c)
|
||||
| [ `Field_annot _ as b ] ->
|
||||
ok (None, Some b, None)
|
||||
| [ `Field_annot _ as b; `Field_annot _ as c ] ->
|
||||
ok (None, Some b, Some c)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let check_const_type_annot
|
||||
: int -> string list -> type_annot option -> unit tzresult Lwt.t
|
||||
= fun loc annot expected_annot ->
|
||||
Lwt.return
|
||||
(parse_type_annot loc annot >>? merge_type_annot expected_annot >|? fun _ -> ())
|
||||
|
||||
let parse_field_annot
|
||||
: int -> string list -> field_annot option tzresult
|
||||
= fun loc annot ->
|
||||
parse_annots loc annot >>?
|
||||
function
|
||||
| [] -> ok None
|
||||
| [ `Field_annot _ as a ] -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc) (* (Invalid_var_annotation (loc, annot)) *)
|
||||
|
||||
let extract_field_annot
|
||||
: Script.node -> (Script.node * field_annot option) tzresult
|
||||
= function
|
||||
| Prim (loc, prim, args, annot) ->
|
||||
let field_annots, annot = List.partition (fun s ->
|
||||
match s.[0] with
|
||||
| '%' -> true
|
||||
| _ -> false
|
||||
| exception Invalid_argument _ -> false
|
||||
) annot in
|
||||
parse_field_annot loc field_annots >|? fun field_annot ->
|
||||
Prim (loc, prim, args, annot), field_annot
|
||||
| expr -> ok (expr, None)
|
||||
|
||||
let check_correct_field
|
||||
: field_annot option -> field_annot option -> unit tzresult
|
||||
= fun f1 f2 ->
|
||||
match f1, f2 with
|
||||
| None, _ | _, None -> ok ()
|
||||
| Some `Field_annot s1, Some `Field_annot s2 ->
|
||||
if String.equal s1 s2 then ok ()
|
||||
else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))
|
||||
|
||||
let parse_var_annot
|
||||
: int -> ?default:var_annot option -> string list ->
|
||||
var_annot option tzresult Lwt.t
|
||||
= fun loc ?default annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
begin match annot, default with
|
||||
| [], None -> ok None
|
||||
| [], Some d -> ok d
|
||||
| [ `Var_annot _ as a ], _ -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc) (* (Invalid_var_annotation (loc, annot)) *)
|
||||
end |> Lwt.return
|
||||
|
||||
let parse_field_annot loc annot =
|
||||
Lwt.return (parse_field_annot loc annot)
|
||||
|
||||
let classify_annot
|
||||
: annot list -> var_annot list * type_annot list * field_annot list * binding_annot list
|
||||
= fun l ->
|
||||
let rv, rt, rf, rb = List.fold_left (fun (rv, rt, rf, rb) -> function
|
||||
| `Var_annot _ as a -> a :: rv, rt, rf, rb
|
||||
| `Type_annot _ as a -> rv, a :: rt, rf, rb
|
||||
| `Field_annot _ as a -> rv, rt, a :: rf, rb
|
||||
| `Binding_annot _ as a -> rv, rt, rf, a :: rb
|
||||
) ([], [], [], []) l in
|
||||
List.rev rv, List.rev rt, List.rev rf, List.rev rb
|
||||
|
||||
let get_one_annot loc = function
|
||||
| [] -> Lwt.return (ok None)
|
||||
| [ a ] -> Lwt.return (ok (Some a))
|
||||
| _ -> Lwt.return (error (Unexpected_annotation loc))
|
||||
|
||||
let get_two_annot loc = function
|
||||
| [] -> Lwt.return (ok (None, None))
|
||||
| [ a ] -> Lwt.return (ok (Some a, None))
|
||||
| [ a; b ] -> Lwt.return (ok (Some a, Some b))
|
||||
| _ -> Lwt.return (error (Unexpected_annotation loc))
|
||||
|
||||
let parse_constr_annot
|
||||
: int -> string list ->
|
||||
(var_annot option * type_annot option * field_annot option * field_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc bindings >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc types >>=? fun t ->
|
||||
get_two_annot loc fields >>|? fun (f1, f2) ->
|
||||
(v, t, f1, f2)
|
||||
|
||||
let parse_map_annot
|
||||
: int -> string list ->
|
||||
(var_annot option * type_annot option * binding_annot option * binding_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc types >>=? fun t ->
|
||||
get_two_annot loc bindings >>|? fun (b1, b2) ->
|
||||
(v, t, b1, b2)
|
||||
|
||||
let parse_two_var_annot
|
||||
: int -> string list -> (var_annot option * var_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc bindings >>=? fun () ->
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_two_annot loc vars
|
||||
|
||||
let parse_two_binding_annot
|
||||
: int -> string list -> (binding_annot option * binding_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc vars >>=? fun () ->
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_two_annot loc bindings
|
||||
|
||||
let parse_var_field_annot
|
||||
: int -> string list -> (var_annot option * field_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc bindings >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc fields >>|? fun f ->
|
||||
(v, f)
|
||||
|
||||
let parse_var_type_annot
|
||||
: int -> string list -> (var_annot option * type_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
fail_unexpected_annot loc bindings >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc types >>|? fun t ->
|
||||
(v, t)
|
||||
|
||||
let parse_binding_annot
|
||||
: int -> string list -> binding_annot option tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc vars >>=? fun () ->
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_one_annot loc bindings
|
||||
|
||||
let parse_var_binding_annot
|
||||
: int -> string list -> (var_annot option * binding_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (parse_annots loc annot) >>=? fun annot ->
|
||||
let vars, types, fields, bindings = classify_annot annot in
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc bindings >>|? fun b ->
|
||||
(v, b)
|
||||
148
src/proto_alpha/lib_protocol/src/script_ir_annot.mli
Normal file
148
src/proto_alpha/lib_protocol/src/script_ir_annot.mli
Normal file
@ -0,0 +1,148 @@
|
||||
(**************************************************************************)
|
||||
(* *)
|
||||
(* Copyright (c) 2014 - 2018. *)
|
||||
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
||||
(* *)
|
||||
(* All rights reserved. No warranty, explicit or implicit, provided. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
open Alpha_context
|
||||
open Script_typed_ir
|
||||
|
||||
(** Default annotations *)
|
||||
|
||||
val default_now_annot : var_annot option
|
||||
val default_amount_annot : var_annot option
|
||||
val default_balance_annot : var_annot option
|
||||
val default_steps_annot : var_annot option
|
||||
val default_source_annot : var_annot option
|
||||
val default_self_annot : var_annot option
|
||||
|
||||
val default_param_annot : field_annot option
|
||||
val default_storage_annot : field_annot option
|
||||
val default_car_annot : field_annot option
|
||||
val default_cdr_annot : field_annot option
|
||||
val default_contract_annot : field_annot option
|
||||
val default_addr_annot : field_annot option
|
||||
val default_manager_annot : field_annot option
|
||||
|
||||
val default_arg_annot : binding_annot option
|
||||
val default_elt_annot : binding_annot option
|
||||
val default_key_annot : binding_annot option
|
||||
val default_hd_annot : binding_annot option
|
||||
val default_some_annot : binding_annot option
|
||||
val default_left_annot : binding_annot option
|
||||
val default_right_annot : binding_annot option
|
||||
|
||||
(** Unparse annotations to their string representation *)
|
||||
|
||||
val unparse_type_annot : type_annot option -> string list
|
||||
val unparse_var_annot : var_annot option -> string list
|
||||
val unparse_field_annot : field_annot option -> string list
|
||||
val unparse_binding_annot : binding_annot option -> string list
|
||||
|
||||
(** Convertions functions between different annotation kinds *)
|
||||
|
||||
val field_to_var_annot : field_annot option -> var_annot option
|
||||
val field_to_binding_annot : field_annot option -> binding_annot option
|
||||
val binding_to_var_annot : binding_annot option -> var_annot option
|
||||
val binding_to_field_annot : binding_annot option -> field_annot option
|
||||
val var_to_binding_annot : var_annot option -> binding_annot option
|
||||
val type_to_field_annot : type_annot option -> field_annot option
|
||||
val var_to_field_annot : var_annot option -> field_annot option
|
||||
|
||||
(** Replace an annotation by its default value if it is [None] *)
|
||||
val default_annot : default:'a option -> 'a option -> 'a option
|
||||
|
||||
(** Generate annotation for field accesses, of the form @var.field1.field2 *)
|
||||
val gen_access_annot :
|
||||
var_annot option ->
|
||||
?default:field_annot option -> field_annot option -> var_annot option
|
||||
|
||||
(** Generate a binding annotation, of the form $var.some *)
|
||||
val gen_binding_access_annot :
|
||||
var_annot option ->
|
||||
?default:binding_annot option ->
|
||||
binding_annot option -> binding_annot option
|
||||
|
||||
(** Merge type annotations.
|
||||
@returns {!Inconsistent_type_annotations} if they are both present and different *)
|
||||
val merge_type_annot :
|
||||
type_annot option -> type_annot option -> type_annot option tzresult
|
||||
|
||||
(** Merge field annotations, does not fail ([None] if different). *)
|
||||
val merge_field_annot :
|
||||
field_annot option -> field_annot option -> field_annot option tzresult
|
||||
|
||||
(** Merge variable annotations, does not fail ([None] if different). *)
|
||||
val merge_var_annot :
|
||||
var_annot option -> var_annot option -> var_annot option
|
||||
|
||||
(** @returns an error {!Unexpected_annotation} in the monad the list is not empty. *)
|
||||
val error_unexpected_annot : int -> 'a list -> unit tzresult
|
||||
|
||||
(** Same as {!error_unexpected_annot} in Lwt. *)
|
||||
val fail_unexpected_annot : int -> 'a list -> unit tzresult Lwt.t
|
||||
|
||||
(** Parse string annotations. *)
|
||||
val parse_annots : int -> string list -> annot list tzresult
|
||||
|
||||
(** Parse a type annotation only. *)
|
||||
val parse_type_annot : int -> string list -> type_annot option tzresult
|
||||
|
||||
(** Parse an annotation for composed types, of the form
|
||||
[:ty_name %field1 %field2] in any order. *)
|
||||
val parse_composed_type_annot :
|
||||
int -> string list ->
|
||||
(type_annot option * field_annot option * field_annot option) tzresult
|
||||
|
||||
(** Check that type annotations are consistent *)
|
||||
val check_const_type_annot :
|
||||
int -> string list -> type_annot option -> unit tzresult Lwt.t
|
||||
|
||||
(** Extract and remove a field annotation from a node *)
|
||||
val extract_field_annot :
|
||||
Script.node -> (Script.node * field_annot option) tzresult
|
||||
|
||||
(** Check that field annotations match, used for field accesses. *)
|
||||
val check_correct_field :
|
||||
field_annot option -> field_annot option -> unit tzresult
|
||||
|
||||
(** Instruction annotations parsing *)
|
||||
|
||||
(** Parse a variable annotation, replaced by a default value if [None]. *)
|
||||
val parse_var_annot :
|
||||
int ->
|
||||
?default:var_annot option ->
|
||||
string list -> var_annot option tzresult Lwt.t
|
||||
|
||||
val parse_field_annot :
|
||||
int -> string list -> field_annot option tzresult Lwt.t
|
||||
|
||||
val parse_constr_annot :
|
||||
int -> string list ->
|
||||
(var_annot option * type_annot option * field_annot option * field_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_map_annot :
|
||||
int -> string list ->
|
||||
(var_annot option * type_annot option * binding_annot option * binding_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_two_var_annot :
|
||||
int -> string list -> (var_annot option * var_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_two_binding_annot :
|
||||
int -> string list ->
|
||||
(binding_annot option * binding_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_var_field_annot :
|
||||
int -> string list -> (var_annot option * field_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_var_type_annot :
|
||||
int -> string list -> (var_annot option * type_annot option) tzresult Lwt.t
|
||||
|
||||
val parse_binding_annot :
|
||||
int -> string list -> binding_annot option tzresult Lwt.t
|
||||
|
||||
val parse_var_binding_annot :
|
||||
int -> string list -> (var_annot option * binding_annot option) tzresult Lwt.t
|
||||
@ -12,6 +12,7 @@ open Micheline
|
||||
open Script
|
||||
open Script_typed_ir
|
||||
open Script_tc_errors
|
||||
open Script_ir_annot
|
||||
|
||||
type ex_comparable_ty = Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty
|
||||
type ex_ty = Ex_ty : 'a ty -> ex_ty
|
||||
@ -32,44 +33,6 @@ let add_dip ty annot prev =
|
||||
| Lambda | Toplevel _ -> Dip (Item_t (ty, Empty_t, annot), prev)
|
||||
| Dip (stack, _) -> Dip (Item_t (ty, stack, annot), prev)
|
||||
|
||||
let default_arg_annot = Some (`Var_annot "arg")
|
||||
let default_now_annot = Some (`Var_annot "now")
|
||||
let default_amount_annot = Some (`Var_annot "amount")
|
||||
let default_balance_annot = Some (`Var_annot "balance")
|
||||
let default_steps_annot = Some (`Var_annot "steps")
|
||||
let default_source_annot = Some (`Var_annot "source")
|
||||
let default_self_annot = Some (`Var_annot "self")
|
||||
|
||||
let default_param_annot = Some (`Field_annot "parameter")
|
||||
let default_storage_annot = Some (`Field_annot "storage")
|
||||
let default_car_annot = Some (`Field_annot "car")
|
||||
let default_cdr_annot = Some (`Field_annot "cdr")
|
||||
let default_left_annot = Some (`Field_annot "left")
|
||||
let default_right_annot = Some (`Field_annot "right")
|
||||
let default_some_annot = Some (`Field_annot "some")
|
||||
let default_elt_annot = Some (`Field_annot "elt")
|
||||
let default_key_annot = Some (`Field_annot "key")
|
||||
let default_hd_annot = Some (`Field_annot "hd")
|
||||
let default_contract_annot = Some (`Field_annot "contract")
|
||||
let default_addr_annot = Some (`Field_annot "address")
|
||||
let default_manager_annot = Some (`Field_annot "manager")
|
||||
|
||||
let default_annot ~default = function
|
||||
| None -> default
|
||||
| annot -> annot
|
||||
|
||||
let access_annot
|
||||
: var_annot option -> ?default:field_annot option -> field_annot option -> var_annot option
|
||||
= fun value_annot ?(default=None) field_annot ->
|
||||
match value_annot, field_annot, default with
|
||||
| None, None, _ | Some _, None, None -> None
|
||||
| None, Some `Field_annot f, _ ->
|
||||
Some (`Var_annot f)
|
||||
| Some `Var_annot v, None, Some `Field_annot f ->
|
||||
Some (`Var_annot (String.concat "." [v; f]))
|
||||
| Some `Var_annot v, Some `Field_annot f, _ ->
|
||||
Some (`Var_annot (String.concat "." [v; f]))
|
||||
|
||||
(* ---- Type size accounting ------------------------------------------------*)
|
||||
|
||||
(* TODO include annot in size ? *)
|
||||
@ -540,18 +503,6 @@ let ty_of_comparable_ty
|
||||
| Timestamp_key tname -> Timestamp_t tname
|
||||
| Address_key tname -> Address_t tname
|
||||
|
||||
let unparse_type_annot : type_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Type_annot a -> [ ":" ^ a ]
|
||||
|
||||
let unparse_var_annot : var_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Var_annot a -> [ "@" ^ a ]
|
||||
|
||||
let unparse_field_annot : field_annot option -> string list = function
|
||||
| None -> []
|
||||
| Some `Field_annot a -> [ "%" ^ a ]
|
||||
|
||||
let unparse_comparable_ty
|
||||
: type a. a comparable_ty -> Script.node
|
||||
= function
|
||||
@ -736,41 +687,6 @@ let rec stack_ty_eq
|
||||
| Empty_t, Empty_t -> Ok Eq
|
||||
| _, _ -> error Bad_stack_length
|
||||
|
||||
let merge_type_annot
|
||||
: type_annot option -> type_annot option -> type_annot option tzresult
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> ok None
|
||||
| Some `Type_annot a1, Some `Type_annot a2 ->
|
||||
if String.equal a1 a2
|
||||
then ok annot1
|
||||
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
|
||||
|
||||
let merge_field_annot
|
||||
: field_annot option -> field_annot option -> field_annot option tzresult
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> ok None
|
||||
| Some `Field_annot a1, Some `Field_annot a2 ->
|
||||
if String.equal a1 a2
|
||||
then ok annot1
|
||||
else ok None (* TODO check this, do we want typechecking here ?
|
||||
error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2)) *)
|
||||
|
||||
let merge_var_annot
|
||||
: var_annot option -> var_annot option -> var_annot option
|
||||
= fun annot1 annot2 ->
|
||||
match annot1, annot2 with
|
||||
| None, None
|
||||
| Some _, None
|
||||
| None, Some _ -> None
|
||||
| Some `Var_annot a1, Some `Var_annot a2 ->
|
||||
if String.equal a1 a2 then annot1 else None
|
||||
|
||||
let merge_comparable_types
|
||||
: type ta. ta comparable_ty -> ta comparable_ty -> ta comparable_ty tzresult
|
||||
= fun ta tb ->
|
||||
@ -801,20 +717,12 @@ let merge_comparable_types
|
||||
Address_key annot
|
||||
| _, _ -> assert false (* FIXME: fix injectivity of some types *)
|
||||
|
||||
let error_unexpected_annot loc annot =
|
||||
match annot with
|
||||
| [] -> ok ()
|
||||
| _ :: _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let rec strip_annotations = function
|
||||
| (Int (_,_) as i) -> i
|
||||
| (String (_,_) as s) -> s
|
||||
| Prim (loc, prim, args, _) -> Prim (loc, prim, List.map strip_annotations args, [])
|
||||
| Seq (loc, items) -> Seq (loc, List.map strip_annotations items)
|
||||
|
||||
let fail_unexpected_annot loc annot =
|
||||
Lwt.return (error_unexpected_annot loc annot)
|
||||
|
||||
let merge_types :
|
||||
type b.Script.location -> b ty -> b ty -> b ty tzresult =
|
||||
let rec help : type a.a ty -> a ty -> a ty tzresult
|
||||
@ -965,82 +873,6 @@ let merge_branches
|
||||
|
||||
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
|
||||
|
||||
let annots_of_strings loc l =
|
||||
List.fold_left (fun acc s ->
|
||||
match acc with
|
||||
| Ok acc ->
|
||||
begin match s.[0] with
|
||||
| '@' -> ok (`Var_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| ':' -> ok (`Type_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| '%' -> ok (`Field_annot (String.sub s 1 @@ String.length s - 1) :: acc)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
| exception Invalid_argument _ -> error (Unexpected_annotation loc)
|
||||
end
|
||||
| Error _ -> acc
|
||||
) (ok []) l
|
||||
>|? List.rev
|
||||
|
||||
let parse_type_annot
|
||||
: int -> string list -> type_annot option tzresult
|
||||
= fun loc annot ->
|
||||
annots_of_strings loc annot >>? function
|
||||
| [] -> ok None
|
||||
| [ `Type_annot _ as a ] -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let parse_composed_type_annot
|
||||
: int -> string list -> (type_annot option * field_annot option * field_annot option) tzresult
|
||||
= fun loc annot ->
|
||||
annots_of_strings loc annot >>? function
|
||||
| [] -> ok (None, None, None)
|
||||
| [ `Type_annot _ as a ] -> ok (Some a, None, None)
|
||||
| [ `Type_annot _ as a ; `Field_annot _ as b] -> ok (Some a, Some b, None)
|
||||
| [ `Type_annot _ as a ; `Field_annot _ as b; `Field_annot _ as c ] ->
|
||||
ok (Some a, Some b, Some c)
|
||||
| [ `Field_annot _ as b ] ->
|
||||
ok (None, Some b, None)
|
||||
| [ `Field_annot _ as b; `Field_annot _ as c ] ->
|
||||
ok (None, Some b, Some c)
|
||||
| _ -> error (Unexpected_annotation loc)
|
||||
|
||||
let check_const_type_annot
|
||||
: int -> string list -> type_annot option -> unit tzresult Lwt.t
|
||||
= fun loc annot expected_annot ->
|
||||
Lwt.return
|
||||
(parse_type_annot loc annot >>? merge_type_annot expected_annot >|? fun _ -> ())
|
||||
|
||||
let parse_field_annot
|
||||
: int -> string list -> field_annot option tzresult
|
||||
= fun loc annot ->
|
||||
annots_of_strings loc annot >>?
|
||||
function
|
||||
| [] -> ok None
|
||||
| [ `Field_annot _ as a ] -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc) (* (Invalid_var_annotation (loc, annot)) *)
|
||||
|
||||
let extract_field_annot
|
||||
: Script.node -> (Script.node * field_annot option) tzresult
|
||||
= function
|
||||
| Prim (loc, prim, args, annot) ->
|
||||
let field_annots, annot = List.partition (fun s ->
|
||||
match s.[0] with
|
||||
| '%' -> true
|
||||
| _ -> false
|
||||
| exception Invalid_argument _ -> false
|
||||
) annot in
|
||||
parse_field_annot loc field_annots >|? fun field_annot ->
|
||||
Prim (loc, prim, args, annot), field_annot
|
||||
| expr -> ok (expr, None)
|
||||
|
||||
let check_correct_field
|
||||
: field_annot option -> field_annot option -> unit tzresult
|
||||
= fun f1 f2 ->
|
||||
match f1, f2 with
|
||||
| None, _ | _, None -> ok ()
|
||||
| Some `Field_annot s1, Some `Field_annot s2 ->
|
||||
if String.equal s1 s2 then ok ()
|
||||
else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))
|
||||
|
||||
let rec parse_comparable_ty
|
||||
: Script.node -> ex_comparable_ty tzresult
|
||||
= function
|
||||
@ -1219,122 +1051,6 @@ let rec unparse_stack
|
||||
|
||||
type ex_script = Ex_script : ('a, 'c) script -> ex_script
|
||||
|
||||
let parse_var_annot
|
||||
: int -> ?default:var_annot option -> string list ->
|
||||
var_annot option tzresult Lwt.t
|
||||
= fun loc ?default annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
begin match annot, default with
|
||||
| [], None -> ok None
|
||||
| [], Some d -> ok d
|
||||
| [ `Var_annot _ as a ], _ -> ok (Some a)
|
||||
| _ -> error (Unexpected_annotation loc) (* (Invalid_var_annotation (loc, annot)) *)
|
||||
end |> Lwt.return
|
||||
|
||||
let parse_field_annot loc annot =
|
||||
Lwt.return (parse_field_annot loc annot)
|
||||
|
||||
let classify_annot
|
||||
: annot list -> var_annot list * type_annot list * field_annot list
|
||||
= fun l ->
|
||||
let rv, rt, rf = List.fold_left (fun (rv, rt, rf) -> function
|
||||
| `Var_annot _ as a -> a :: rv, rt, rf
|
||||
| `Type_annot _ as a -> rv, a :: rt, rf
|
||||
| `Field_annot _ as a -> rv, rt, a :: rf
|
||||
) ([], [], []) l in
|
||||
List.rev rv, List.rev rt, List.rev rf
|
||||
|
||||
let get_one_annot loc = function
|
||||
| [] -> Lwt.return (ok None)
|
||||
| [ a ] -> Lwt.return (ok (Some a))
|
||||
| _ -> Lwt.return (error (Unexpected_annotation loc))
|
||||
|
||||
let get_two_annot loc = function
|
||||
| [] -> Lwt.return (ok (None, None))
|
||||
| [ a ] -> Lwt.return (ok (Some a, None))
|
||||
| [ a; b ] -> Lwt.return (ok (Some a, Some b))
|
||||
| _ -> Lwt.return (error (Unexpected_annotation loc))
|
||||
|
||||
let parse_constr_annot
|
||||
: int -> string list ->
|
||||
(var_annot option * type_annot option * field_annot option * field_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
let vars, types, fields = classify_annot annot in
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc types >>=? fun t ->
|
||||
get_two_annot loc fields >>|? fun (f1, f2) ->
|
||||
(v, t, f1, f2)
|
||||
|
||||
let parse_two_var_annot
|
||||
: int -> string list -> (var_annot option * var_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
let vars, types, fields = classify_annot annot in
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_two_annot loc vars
|
||||
|
||||
let parse_two_field_annot
|
||||
: int -> string list -> (field_annot option * field_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
let vars, types, fields = classify_annot annot in
|
||||
fail_unexpected_annot loc vars >>=? fun () ->
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
get_two_annot loc fields
|
||||
|
||||
|
||||
let parse_var_field_annot
|
||||
: int -> string list -> (var_annot option * field_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
let vars, types, fields = classify_annot annot in
|
||||
fail_unexpected_annot loc types >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc fields >>|? fun f ->
|
||||
(v, f)
|
||||
|
||||
let parse_var_type_annot
|
||||
: int -> string list -> (var_annot option * type_annot option) tzresult Lwt.t
|
||||
= fun loc annot ->
|
||||
Lwt.return (annots_of_strings loc annot) >>=? fun annot ->
|
||||
let vars, types, fields = classify_annot annot in
|
||||
fail_unexpected_annot loc fields >>=? fun () ->
|
||||
get_one_annot loc vars >>=? fun v ->
|
||||
get_one_annot loc types >>|? fun t ->
|
||||
(v, t)
|
||||
|
||||
(* let check_and_remove_type_annot
|
||||
* : type a. Script.node -> a stack_ty -> Script.node tzresult Lwt.t
|
||||
* = fun instr stack ->
|
||||
* match instr, stack with
|
||||
* | Prim (loc, prim, args, annot), Item_t (ty, _, _) ->
|
||||
* let type_annots, annot = List.partition (fun s ->
|
||||
* match s.[0] with
|
||||
* | ':' -> true
|
||||
* | _ -> false
|
||||
* | exception Invalid_argument _ -> false
|
||||
* ) annot in
|
||||
* check_const_type_annot loc type_annots (name_of_ty ty) >>|? fun () ->
|
||||
* Prim (loc, prim, args, annot)
|
||||
* | _ -> Lwt.return @@ ok @@ instr *)
|
||||
|
||||
let field_to_var_annot : field_annot option -> var_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Field_annot s) -> Some (`Var_annot s)
|
||||
|
||||
let type_to_field_annot : type_annot option -> field_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Type_annot s) -> Some (`Field_annot s)
|
||||
|
||||
let var_to_field_annot : var_annot option -> field_annot option =
|
||||
function
|
||||
| None -> None
|
||||
| Some (`Var_annot s) -> Some (`Field_annot s)
|
||||
|
||||
let public_key_hash_size =
|
||||
match Data_encoding.Binary.fixed_length Signature.Public_key_hash.encoding with
|
||||
| None -> assert false
|
||||
@ -1772,11 +1488,13 @@ and parse_instr
|
||||
(Item_t (Option_t ((t, some_field), _none_field, _), rest, option_annot) as bef) ->
|
||||
check_kind [ Seq_kind ] bt >>=? fun () ->
|
||||
check_kind [ Seq_kind ] bf >>=? fun () ->
|
||||
parse_var_annot loc annot
|
||||
~default:(access_annot option_annot some_field ~default:default_some_annot)
|
||||
>>=? fun some_annot ->
|
||||
parse_binding_annot loc annot >>=? fun binding_annot ->
|
||||
let binding_annot = default_annot binding_annot
|
||||
~default:(gen_binding_access_annot option_annot (field_to_binding_annot some_field)
|
||||
~default:default_some_annot) in
|
||||
let annot = binding_to_var_annot binding_annot in
|
||||
parse_instr ?type_logger tc_context ctxt bt rest >>=? fun (btr, ctxt) ->
|
||||
parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, some_annot)) >>=? fun (bfr, ctxt) ->
|
||||
parse_instr ?type_logger tc_context ctxt bf (Item_t (t, rest, annot)) >>=? fun (bfr, ctxt) ->
|
||||
let branch ibt ibf =
|
||||
{ loc ; instr = If_none (ibt, ibf) ; bef ; aft = ibt.aft } in
|
||||
merge_branches loc btr bfr { branch } >>=? fun judgement ->
|
||||
@ -1793,14 +1511,14 @@ and parse_instr
|
||||
Item_t (Pair_t ((a, expected_field_annot), _, _), rest, pair_annot) ->
|
||||
parse_var_field_annot loc annot >>=? fun (annot, field_annot) ->
|
||||
let annot = default_annot annot
|
||||
~default:(access_annot pair_annot expected_field_annot ~default:default_car_annot) in
|
||||
~default:(gen_access_annot pair_annot expected_field_annot ~default:default_car_annot) in
|
||||
Lwt.return (check_correct_field field_annot expected_field_annot) >>=? fun () ->
|
||||
typed ctxt loc Car (Item_t (a, rest, annot))
|
||||
| Prim (loc, I_CDR, [], annot),
|
||||
Item_t (Pair_t (_, (b, expected_field_annot), _), rest, pair_annot) ->
|
||||
parse_var_field_annot loc annot >>=? fun (annot, field_annot) ->
|
||||
let annot = default_annot annot
|
||||
~default:(access_annot pair_annot expected_field_annot ~default:default_cdr_annot) in
|
||||
~default:(gen_access_annot pair_annot expected_field_annot ~default:default_cdr_annot) in
|
||||
Lwt.return (check_correct_field field_annot expected_field_annot) >>=? fun () ->
|
||||
typed ctxt loc Cdr (Item_t (b, rest, annot))
|
||||
(* unions *)
|
||||
@ -1818,11 +1536,17 @@ and parse_instr
|
||||
(Item_t (Union_t ((tl, l_field), (tr, r_field), _), rest, union_annot) as bef) ->
|
||||
check_kind [ Seq_kind ] bt >>=? fun () ->
|
||||
check_kind [ Seq_kind ] bf >>=? fun () ->
|
||||
parse_two_var_annot loc annot >>=? fun (left_annot, right_annot) ->
|
||||
let left_annot = default_annot left_annot
|
||||
~default:(access_annot union_annot l_field ~default:default_left_annot) in
|
||||
let right_annot = default_annot right_annot
|
||||
~default:(access_annot union_annot r_field ~default:default_right_annot) in
|
||||
parse_two_binding_annot loc annot >>=? fun (left_bind_annot, right_bind_annot) ->
|
||||
let left_bind_annot = default_annot left_bind_annot
|
||||
~default:(gen_binding_access_annot union_annot
|
||||
(field_to_binding_annot l_field)
|
||||
~default:default_left_annot) in
|
||||
let left_annot = binding_to_var_annot left_bind_annot in
|
||||
let right_bind_annot = default_annot right_bind_annot
|
||||
~default:(gen_binding_access_annot union_annot
|
||||
(field_to_binding_annot r_field)
|
||||
~default:default_right_annot) in
|
||||
let right_annot = binding_to_var_annot right_bind_annot in
|
||||
parse_instr ?type_logger tc_context ctxt bt (Item_t (tl, rest, left_annot)) >>=? fun (btr, ctxt) ->
|
||||
parse_instr ?type_logger tc_context ctxt bf (Item_t (tr, rest, right_annot)) >>=? fun (bfr, ctxt) ->
|
||||
let branch ibt ibf =
|
||||
@ -1844,8 +1568,10 @@ and parse_instr
|
||||
(Item_t (List_t (t, _), rest, list_annot) as bef) ->
|
||||
check_kind [ Seq_kind ] bt >>=? fun () ->
|
||||
check_kind [ Seq_kind ] bf >>=? fun () ->
|
||||
parse_var_annot loc annot ~default:(access_annot list_annot default_hd_annot)
|
||||
>>=? fun hd_annot ->
|
||||
parse_binding_annot loc annot >>=? fun hd_bind_annot ->
|
||||
let hd_bind_annot = default_annot hd_bind_annot
|
||||
~default:(gen_binding_access_annot list_annot default_hd_annot) in
|
||||
let hd_annot = binding_to_var_annot hd_bind_annot in
|
||||
parse_instr ?type_logger tc_context ctxt bt
|
||||
(Item_t (t, bef, hd_annot)) >>=? fun (btr, ctxt) ->
|
||||
parse_instr ?type_logger tc_context ctxt bf
|
||||
@ -1861,9 +1587,10 @@ and parse_instr
|
||||
| Prim (loc, I_MAP, [ body ], annot),
|
||||
(Item_t (List_t (elt, _), starting_rest, list_annot)) ->
|
||||
check_kind [ Seq_kind ] body >>=? fun () ->
|
||||
parse_var_field_annot loc annot >>=? fun (ret_annot, elt_annot) ->
|
||||
let elt_annot = default_annot (field_to_var_annot elt_annot)
|
||||
~default:(access_annot list_annot default_elt_annot) in
|
||||
parse_var_binding_annot loc annot >>=? fun (ret_annot, elt_bind_annot) ->
|
||||
let elt_bind_annot = default_annot elt_bind_annot
|
||||
~default:(gen_binding_access_annot list_annot default_elt_annot) in
|
||||
let elt_annot = binding_to_var_annot elt_bind_annot in
|
||||
parse_instr ?type_logger tc_context ctxt
|
||||
body (Item_t (elt, starting_rest, elt_annot)) >>=? begin fun (judgement, ctxt) ->
|
||||
match judgement with
|
||||
@ -1879,9 +1606,10 @@ and parse_instr
|
||||
| Prim (loc, I_ITER, [ body ], annot),
|
||||
Item_t (List_t (elt, _), rest, list_annot) ->
|
||||
check_kind [ Seq_kind ] body >>=? fun () ->
|
||||
parse_field_annot loc annot >>=? fun elt_annot ->
|
||||
let elt_annot = default_annot (field_to_var_annot elt_annot)
|
||||
~default:(access_annot list_annot default_elt_annot) in
|
||||
parse_binding_annot loc annot >>=? fun elt_bind_annot ->
|
||||
let elt_bind_annot = default_annot elt_bind_annot
|
||||
~default:(gen_binding_access_annot list_annot default_elt_annot) in
|
||||
let elt_annot = binding_to_var_annot elt_bind_annot in
|
||||
parse_instr ?type_logger tc_context ctxt
|
||||
body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) ->
|
||||
match judgement with
|
||||
@ -1902,9 +1630,10 @@ and parse_instr
|
||||
| Prim (loc, I_ITER, [ body ], annot),
|
||||
Item_t (Set_t (comp_elt, _), rest, set_annot) ->
|
||||
check_kind [ Seq_kind ] body >>=? fun () ->
|
||||
parse_field_annot loc annot >>=? fun elt_annot ->
|
||||
let elt_annot = default_annot (field_to_var_annot elt_annot)
|
||||
~default:(access_annot set_annot default_elt_annot) in
|
||||
parse_binding_annot loc annot >>=? fun elt_bind_annot ->
|
||||
let elt_bind_annot = default_annot elt_bind_annot
|
||||
~default:(gen_binding_access_annot set_annot default_elt_annot) in
|
||||
let elt_annot = binding_to_var_annot elt_bind_annot in
|
||||
let elt = ty_of_comparable_ty comp_elt in
|
||||
parse_instr ?type_logger tc_context ctxt
|
||||
body (Item_t (elt, rest, elt_annot)) >>=? begin fun (judgement, ctxt) ->
|
||||
@ -1944,9 +1673,9 @@ and parse_instr
|
||||
Item_t (Map_t (ck, elt, _), starting_rest, _map_annot) ->
|
||||
let k = ty_of_comparable_ty ck in
|
||||
check_kind [ Seq_kind ] body >>=? fun () ->
|
||||
parse_constr_annot loc annot >>=? fun (ret_annot, ty_name, key_annot, elt_annot) ->
|
||||
let key_field = default_annot key_annot ~default:default_key_annot in
|
||||
let elt_field = default_annot elt_annot ~default:default_elt_annot in
|
||||
parse_map_annot loc annot >>=? fun (ret_annot, ty_name, key_bind_annot, elt_bind_annot) ->
|
||||
let key_field = default_annot key_bind_annot ~default:default_key_annot |> binding_to_field_annot in
|
||||
let elt_field = default_annot elt_bind_annot ~default:default_elt_annot |> binding_to_field_annot in
|
||||
parse_instr ?type_logger tc_context ctxt
|
||||
body (Item_t (Pair_t ((k, key_field), (elt, elt_field), None), starting_rest, None)) >>=? begin fun (judgement, ctxt) ->
|
||||
match judgement with
|
||||
@ -1962,9 +1691,9 @@ and parse_instr
|
||||
| Prim (loc, I_ITER, [ body ], annot),
|
||||
Item_t (Map_t (comp_elt, element_ty, _), rest, _) ->
|
||||
check_kind [ Seq_kind ] body >>=? fun () ->
|
||||
parse_two_field_annot loc annot >>=? fun (key_annot, elt_annot) ->
|
||||
let key_field = default_annot key_annot ~default:default_key_annot in
|
||||
let elt_field = default_annot elt_annot ~default:default_elt_annot in
|
||||
parse_two_binding_annot loc annot >>=? fun (key_bind_annot, elt_bind_annot) ->
|
||||
let key_field = default_annot key_bind_annot ~default:default_key_annot |> binding_to_field_annot in
|
||||
let elt_field = default_annot elt_bind_annot ~default:default_elt_annot |> binding_to_field_annot in
|
||||
let key = ty_of_comparable_ty comp_elt in
|
||||
parse_instr ?type_logger tc_context ctxt body
|
||||
(Item_t (Pair_t ((key, key_field), (element_ty, elt_field), None), rest, None))
|
||||
@ -2094,7 +1823,7 @@ and parse_instr
|
||||
fail_unexpected_annot loc annot >>=? fun () ->
|
||||
parse_var_field_annot loc annot >>=? fun (r_annot, l_annot) ->
|
||||
let l_annot = default_annot (field_to_var_annot l_annot)
|
||||
~default:(access_annot union_annot l_field) in
|
||||
~default:(gen_access_annot union_annot l_field) in
|
||||
parse_instr ?type_logger tc_context ctxt body
|
||||
(Item_t (tl, rest, l_annot)) >>=? begin fun (judgement, ctxt) -> match judgement with
|
||||
| Typed ibody ->
|
||||
@ -2113,8 +1842,9 @@ and parse_instr
|
||||
(Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:true ret))
|
||||
>>=? fun (Ex_ty ret) ->
|
||||
check_kind [ Seq_kind ] code >>=? fun () ->
|
||||
parse_var_field_annot loc annot >>=? fun (annot, arg_annot) ->
|
||||
let arg_annot = default_annot (field_to_var_annot arg_annot) ~default:default_arg_annot in
|
||||
parse_var_binding_annot loc annot >>=? fun (annot, arg_bind_annot) ->
|
||||
let arg_bind_annot = default_annot arg_bind_annot ~default:default_arg_annot in
|
||||
let arg_annot = binding_to_var_annot arg_bind_annot in
|
||||
parse_returning Lambda ?type_logger ctxt
|
||||
(arg, arg_annot) ret code >>=? fun (lambda, ctxt) ->
|
||||
typed ctxt loc (Lambda lambda) (Item_t (Lambda_t (arg, ret, None), stack, annot))
|
||||
@ -2480,26 +2210,26 @@ and parse_instr
|
||||
(* protocol *)
|
||||
| Prim (loc, I_ADDRESS, [], annot),
|
||||
Item_t (Contract_t _, rest, contract_annot) ->
|
||||
parse_var_annot loc annot ~default:(access_annot contract_annot default_addr_annot)
|
||||
parse_var_annot loc annot ~default:(gen_access_annot contract_annot default_addr_annot)
|
||||
>>=? fun annot ->
|
||||
typed ctxt loc Address
|
||||
(Item_t (Address_t None, rest, annot))
|
||||
| Prim (loc, I_CONTRACT, [ ty ], annot),
|
||||
Item_t (Address_t _, rest, addr_annot) ->
|
||||
Lwt.return (parse_ty ~allow_big_map:false ~allow_operation:false ty) >>=? fun (Ex_ty t) ->
|
||||
parse_var_annot loc annot ~default:(access_annot addr_annot default_contract_annot)
|
||||
parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_contract_annot)
|
||||
>>=? fun annot ->
|
||||
typed ctxt loc (Contract t)
|
||||
(Item_t (Option_t ((Contract_t (t, None), None), None, None), rest, annot))
|
||||
| Prim (loc, I_MANAGER, [], annot),
|
||||
Item_t (Contract_t _, rest, contract_annot) ->
|
||||
parse_var_annot loc annot ~default:(access_annot contract_annot default_manager_annot)
|
||||
parse_var_annot loc annot ~default:(gen_access_annot contract_annot default_manager_annot)
|
||||
>>=? fun annot ->
|
||||
typed ctxt loc Manager
|
||||
(Item_t (Key_hash_t None, rest, annot))
|
||||
| Prim (loc, I_MANAGER, [], annot),
|
||||
Item_t (Address_t _, rest, addr_annot) ->
|
||||
parse_var_annot loc annot ~default:(access_annot addr_annot default_manager_annot)
|
||||
parse_var_annot loc annot ~default:(gen_access_annot addr_annot default_manager_annot)
|
||||
>>=? fun annot ->
|
||||
typed ctxt loc Address_manager
|
||||
(Item_t (Option_t ((Key_hash_t None, None), None, None), rest, annot))
|
||||
|
||||
@ -67,7 +67,6 @@ val parse_data :
|
||||
val unparse_data :
|
||||
context -> unparsing_mode -> 'a Script_typed_ir.ty -> 'a ->
|
||||
(Script.node * context) tzresult Lwt.t
|
||||
val unparse_var_annot : Script_typed_ir.var_annot option -> string list
|
||||
|
||||
val parse_ty :
|
||||
allow_big_map: bool ->
|
||||
|
||||
@ -41,8 +41,6 @@ type error += Bad_stack_length
|
||||
type error += Bad_stack_item of int
|
||||
type error += Inconsistent_annotations of string * string
|
||||
type error += Inconsistent_type_annotations : Script.location * _ ty * _ ty -> error
|
||||
type error += Invalid_type_annotation : Script.location * annot list -> error
|
||||
type error += Invalid_var_annotation : Script.location * annot list -> error
|
||||
type error += Inconsistent_field_annotations of string * string
|
||||
type error += Unexpected_annotation of Script.location
|
||||
type error += Invalid_map_body : Script.location * _ stack_ty -> error
|
||||
|
||||
@ -10,27 +10,14 @@
|
||||
open Alpha_context
|
||||
open Script_int
|
||||
|
||||
|
||||
(* ---- Auxiliary types -----------------------------------------------------*)
|
||||
|
||||
type var_annot = [ `Var_annot of string ]
|
||||
type type_annot = [ `Type_annot of string ]
|
||||
type field_annot = [ `Field_annot of string ]
|
||||
type binding_annot = [ `Binding_annot of string ]
|
||||
|
||||
type annot = [ var_annot | type_annot | field_annot ]
|
||||
|
||||
(* type 'ty comparable_ty_desc =
|
||||
* | Int_key : (z num) comparable_ty_desc
|
||||
* | Nat_key : (n num) comparable_ty_desc
|
||||
* | String_key : string comparable_ty_desc
|
||||
* | Mutez_key : Tez.t comparable_ty_desc
|
||||
* | Bool_key : bool comparable_ty_desc
|
||||
* | Key_hash_key : public_key_hash comparable_ty_desc
|
||||
* | Timestamp_key : Script_timestamp.t comparable_ty_desc
|
||||
* | Address_key : Contract.t comparable_ty_desc
|
||||
*
|
||||
* type 'ty comparable_ty =
|
||||
* { comp_ty_desc : 'ty comparable_ty_desc ; comp_ty_name : type_annot option } *)
|
||||
type annot = [ var_annot | type_annot | field_annot | binding_annot ]
|
||||
|
||||
type 'ty comparable_ty =
|
||||
| Int_key : type_annot option -> (z num) comparable_ty
|
||||
@ -80,31 +67,6 @@ and ('arg, 'ret) lambda =
|
||||
and 'arg typed_contract =
|
||||
'arg ty * Contract.t
|
||||
|
||||
(* and 'ty ty_desc =
|
||||
* | Unit_t : unit ty_desc
|
||||
* | Int_t : z num ty_desc
|
||||
* | Nat_t : n num ty_desc
|
||||
* | Signature_t : signature ty_desc
|
||||
* | String_t : string ty_desc
|
||||
* | Mutez_t : Tez.t ty_desc
|
||||
* | Key_hash_t : public_key_hash ty_desc
|
||||
* | Key_t : public_key ty_desc
|
||||
* | Timestamp_t : Script_timestamp.t ty_desc
|
||||
* | Address_t : Contract.t ty_desc
|
||||
* | Bool_t : bool ty_desc
|
||||
* | Pair_t : ('a ty * field_annot option) * ('b ty * field_annot option) -> ('a, 'b) pair ty_desc
|
||||
* | Union_t : ('a ty * field_annot option) * ('b ty * field_annot option) -> ('a, 'b) union ty_desc
|
||||
* | Lambda_t : 'arg ty * 'ret ty -> ('arg, 'ret) lambda ty_desc
|
||||
* | Option_t : ('v ty * field_annot option) * field_annot option -> 'v option ty_desc
|
||||
* | List_t : 'v ty -> 'v list ty_desc
|
||||
* | Set_t : 'v comparable_ty -> 'v set ty_desc
|
||||
* | Map_t : 'k comparable_ty * 'v ty -> ('k, 'v) map ty_desc
|
||||
* | Big_map_t : 'k comparable_ty * 'v ty -> ('k, 'v) big_map ty_desc
|
||||
* | Contract_t : 'arg ty -> 'arg typed_contract ty_desc
|
||||
* | Operation_t : internal_operation ty_desc
|
||||
*
|
||||
* and 'ty ty = { ty_desc : 'ty ty_desc ; ty_name : type_annot option } *)
|
||||
|
||||
and 'ty ty =
|
||||
| Unit_t : type_annot option -> unit ty
|
||||
| Int_t : type_annot option -> z num ty
|
||||
|
||||
Loading…
Reference in New Issue
Block a user