546 lines
17 KiB
OCaml
546 lines
17 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
|
|
(* *)
|
|
(* Permission is hereby granted, free of charge, to any person obtaining a *)
|
|
(* copy of this software and associated documentation files (the "Software"),*)
|
|
(* to deal in the Software without restriction, including without limitation *)
|
|
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
|
|
(* and/or sell copies of the Software, and to permit persons to whom the *)
|
|
(* Software is furnished to do so, subject to the following conditions: *)
|
|
(* *)
|
|
(* The above copyright notice and this permission notice shall be included *)
|
|
(* in all copies or substantial portions of the Software. *)
|
|
(* *)
|
|
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
|
|
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
|
|
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
|
|
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
|
|
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
|
|
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
|
|
(* DEALINGS IN THE SOFTWARE. *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
open 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_sender_annot = Some (`Var_annot "sender")
|
|
|
|
let default_self_annot = Some (`Var_annot "self")
|
|
|
|
let default_arg_annot = Some (`Var_annot "arg")
|
|
|
|
let default_param_annot = Some (`Var_annot "parameter")
|
|
|
|
let default_storage_annot = Some (`Var_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_pack_annot = Some (`Field_annot "packed")
|
|
|
|
let default_unpack_annot = Some (`Field_annot "unpacked")
|
|
|
|
let default_slice_annot = Some (`Field_annot "slice")
|
|
|
|
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_tl_annot = Some (`Field_annot "tl")
|
|
|
|
let default_some_annot = Some (`Field_annot "some")
|
|
|
|
let default_left_annot = Some (`Field_annot "left")
|
|
|
|
let default_right_annot = Some (`Field_annot "right")
|
|
|
|
let default_binding_annot = Some (`Field_annot "bnd")
|
|
|
|
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 field_to_var_annot : field_annot option -> var_annot option = function
|
|
| None ->
|
|
None
|
|
| Some (`Field_annot s) ->
|
|
Some (`Var_annot s)
|
|
|
|
let type_to_var_annot : type_annot option -> var_annot option = function
|
|
| None ->
|
|
None
|
|
| Some (`Type_annot s) ->
|
|
Some (`Var_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, Some (`Field_annot ""), _)
|
|
->
|
|
None
|
|
| (None, Some (`Field_annot f), _) ->
|
|
Some (`Var_annot f)
|
|
| ( Some (`Var_annot v),
|
|
(None | Some (`Field_annot "")),
|
|
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 merge_type_annot :
|
|
legacy:bool ->
|
|
type_annot option ->
|
|
type_annot option ->
|
|
type_annot option tzresult =
|
|
fun ~legacy annot1 annot2 ->
|
|
match (annot1, annot2) with
|
|
| (None, None) | (Some _, None) | (None, Some _) ->
|
|
ok None
|
|
| (Some (`Type_annot a1), Some (`Type_annot a2)) ->
|
|
if legacy || String.equal a1 a2 then ok annot1
|
|
else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))
|
|
|
|
let merge_field_annot :
|
|
legacy:bool ->
|
|
field_annot option ->
|
|
field_annot option ->
|
|
field_annot option tzresult =
|
|
fun ~legacy annot1 annot2 ->
|
|
match (annot1, annot2) with
|
|
| (None, None) | (Some _, None) | (None, Some _) ->
|
|
ok None
|
|
| (Some (`Field_annot a1), Some (`Field_annot a2)) ->
|
|
if legacy || String.equal a1 a2 then ok annot1
|
|
else 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)
|
|
|
|
(* Check that the predicate p holds on all s.[k] for k >= i *)
|
|
let string_iter p s i =
|
|
let len = String.length s in
|
|
let rec aux i =
|
|
if Compare.Int.(i >= len) then ok () else p s.[i] >>? fun () -> aux (i + 1)
|
|
in
|
|
aux i
|
|
|
|
(* Valid annotation characters as defined by the allowed_annot_char function from lib_micheline/micheline_parser *)
|
|
let check_char loc = function
|
|
| 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9' ->
|
|
ok ()
|
|
| _ ->
|
|
error (Unexpected_annotation loc)
|
|
|
|
(* This constant is defined in lib_micheline/micheline_parser which is not available in the environment. *)
|
|
let max_annot_length = 255
|
|
|
|
let parse_annots loc ?(allow_special_var = false)
|
|
?(allow_special_field = false) l =
|
|
(* allow emtpty annotations as wildcards but otherwise only accept
|
|
annotations that start with [a-zA-Z_] *)
|
|
let sub_or_wildcard ~specials wrap s acc =
|
|
let len = String.length s in
|
|
( if Compare.Int.(len > max_annot_length) then
|
|
error (Unexpected_annotation loc)
|
|
else ok () )
|
|
>>? fun () ->
|
|
if Compare.Int.(len = 1) then ok @@ (wrap None :: acc)
|
|
else
|
|
match s.[1] with
|
|
| 'a' .. 'z' | 'A' .. 'Z' | '_' ->
|
|
(* check that all characters are valid*)
|
|
string_iter (check_char loc) s 2
|
|
>>? fun () -> ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc)
|
|
| '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
|
|
ok @@ (wrap (Some "@") :: acc)
|
|
| '%' when List.mem '%' specials ->
|
|
if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc)
|
|
else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then
|
|
ok @@ (wrap (Some "%%") :: acc)
|
|
else error (Unexpected_annotation loc)
|
|
| _ ->
|
|
error (Unexpected_annotation loc)
|
|
in
|
|
List.fold_left
|
|
(fun acc s ->
|
|
acc
|
|
>>? fun acc ->
|
|
if Compare.Int.(String.length s = 0) then
|
|
error (Unexpected_annotation loc)
|
|
else
|
|
match s.[0] with
|
|
| ':' ->
|
|
sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc
|
|
| '@' ->
|
|
sub_or_wildcard
|
|
~specials:(if allow_special_var then ['%'] else [])
|
|
(fun a -> `Var_annot a)
|
|
s
|
|
acc
|
|
| '%' ->
|
|
sub_or_wildcard
|
|
~specials:(if allow_special_field then ['@'] else [])
|
|
(fun a -> `Field_annot a)
|
|
s
|
|
acc
|
|
| _ ->
|
|
error (Unexpected_annotation loc))
|
|
(ok [])
|
|
l
|
|
>|? List.rev
|
|
|
|
let opt_var_of_var_opt = function
|
|
| `Var_annot None ->
|
|
None
|
|
| `Var_annot (Some a) ->
|
|
Some (`Var_annot a)
|
|
|
|
let opt_field_of_field_opt = function
|
|
| `Field_annot None ->
|
|
None
|
|
| `Field_annot (Some a) ->
|
|
Some (`Field_annot a)
|
|
|
|
let opt_type_of_type_opt = function
|
|
| `Type_annot None ->
|
|
None
|
|
| `Type_annot (Some a) ->
|
|
Some (`Type_annot a)
|
|
|
|
let classify_annot loc l :
|
|
(var_annot option list * type_annot option list * field_annot option list)
|
|
tzresult =
|
|
try
|
|
let (_, rv, _, rt, _, rf) =
|
|
List.fold_left
|
|
(fun (in_v, rv, in_t, rt, in_f, rf) a ->
|
|
match (a, in_v, rv, in_t, rt, in_f, rf) with
|
|
| ((`Var_annot _ as a), true, _, _, _, _, _)
|
|
| ((`Var_annot _ as a), false, [], _, _, _, _) ->
|
|
(true, opt_var_of_var_opt a :: rv, false, rt, false, rf)
|
|
| ((`Type_annot _ as a), _, _, true, _, _, _)
|
|
| ((`Type_annot _ as a), _, _, false, [], _, _) ->
|
|
(false, rv, true, opt_type_of_type_opt a :: rt, false, rf)
|
|
| ((`Field_annot _ as a), _, _, _, _, true, _)
|
|
| ((`Field_annot _ as a), _, _, _, _, false, []) ->
|
|
(false, rv, false, rt, true, opt_field_of_field_opt a :: rf)
|
|
| _ ->
|
|
raise Exit)
|
|
(false, [], false, [], false, [])
|
|
l
|
|
in
|
|
ok (List.rev rv, List.rev rt, List.rev rf)
|
|
with Exit -> error (Ungrouped_annotations loc)
|
|
|
|
let get_one_annot loc = function
|
|
| [] ->
|
|
ok None
|
|
| [a] ->
|
|
ok a
|
|
| _ ->
|
|
error (Unexpected_annotation loc)
|
|
|
|
let get_two_annot loc = function
|
|
| [] ->
|
|
ok (None, None)
|
|
| [a] ->
|
|
ok (a, None)
|
|
| [a; b] ->
|
|
ok (a, b)
|
|
| _ ->
|
|
error (Unexpected_annotation loc)
|
|
|
|
let parse_type_annot : int -> string list -> type_annot option tzresult =
|
|
fun loc annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc vars
|
|
>>? fun () ->
|
|
error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types
|
|
|
|
let parse_type_field_annot :
|
|
int -> string list -> (type_annot option * field_annot option) tzresult =
|
|
fun loc annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc vars
|
|
>>? fun () ->
|
|
get_one_annot loc types
|
|
>>? fun t -> get_one_annot loc fields >|? fun f -> (t, f)
|
|
|
|
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 >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc vars
|
|
>>? fun () ->
|
|
get_one_annot loc types
|
|
>>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2)
|
|
|
|
let parse_field_annot : int -> string list -> field_annot option tzresult =
|
|
fun loc annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc vars
|
|
>>? fun () ->
|
|
error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields
|
|
|
|
let extract_field_annot :
|
|
Script.node -> (Script.node * field_annot option) tzresult = function
|
|
| Prim (loc, prim, args, annot) ->
|
|
let rec extract_first acc = function
|
|
| [] ->
|
|
(None, annot)
|
|
| s :: rest ->
|
|
if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%')
|
|
then (Some s, List.rev_append acc rest)
|
|
else extract_first (s :: acc) rest
|
|
in
|
|
let (field_annot, annot) = extract_first [] annot in
|
|
let field_annot =
|
|
match field_annot with
|
|
| None ->
|
|
None
|
|
| Some field_annot ->
|
|
Some
|
|
(`Field_annot
|
|
(String.sub field_annot 1 (String.length field_annot - 1)))
|
|
in
|
|
ok (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 =
|
|
fun loc ?default annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc types
|
|
>>? fun () ->
|
|
error_unexpected_annot loc fields
|
|
>>? fun () ->
|
|
get_one_annot loc vars
|
|
>|? function
|
|
| Some _ as a ->
|
|
a
|
|
| None -> (
|
|
match default with Some a -> a | None -> None )
|
|
|
|
let split_last_dot = function
|
|
| None ->
|
|
(None, None)
|
|
| Some (`Field_annot s) -> (
|
|
match String.rindex_opt s '.' with
|
|
| None ->
|
|
(None, Some (`Field_annot s))
|
|
| Some i ->
|
|
let s1 = String.sub s 0 i in
|
|
let s2 = String.sub s (i + 1) (String.length s - i - 1) in
|
|
let f =
|
|
if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
|
|
then None
|
|
else Some (`Field_annot s2)
|
|
in
|
|
(Some (`Var_annot s1), f) )
|
|
|
|
let common_prefix v1 v2 =
|
|
match (v1, v2) with
|
|
| (Some (`Var_annot s1), Some (`Var_annot s2))
|
|
when Compare.String.equal s1 s2 ->
|
|
v1
|
|
| (Some _, None) ->
|
|
v1
|
|
| (None, Some _) ->
|
|
v2
|
|
| (_, _) ->
|
|
None
|
|
|
|
let parse_constr_annot :
|
|
int ->
|
|
?if_special_first:field_annot option ->
|
|
?if_special_second:field_annot option ->
|
|
string list ->
|
|
( var_annot option
|
|
* type_annot option
|
|
* field_annot option
|
|
* field_annot option )
|
|
tzresult =
|
|
fun loc ?if_special_first ?if_special_second annot ->
|
|
parse_annots ~allow_special_field:true loc annot
|
|
>>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
get_one_annot loc vars
|
|
>>? fun v ->
|
|
get_one_annot loc types
|
|
>>? fun t ->
|
|
get_two_annot loc fields
|
|
>>? fun (f1, f2) ->
|
|
( match (if_special_first, f1) with
|
|
| (Some special_var, Some (`Field_annot "@")) ->
|
|
ok (split_last_dot special_var)
|
|
| (None, Some (`Field_annot "@")) ->
|
|
error (Unexpected_annotation loc)
|
|
| (_, _) ->
|
|
ok (v, f1) )
|
|
>>? fun (v1, f1) ->
|
|
( match (if_special_second, f2) with
|
|
| (Some special_var, Some (`Field_annot "@")) ->
|
|
ok (split_last_dot special_var)
|
|
| (None, Some (`Field_annot "@")) ->
|
|
error (Unexpected_annotation loc)
|
|
| (_, _) ->
|
|
ok (v, f2) )
|
|
>|? fun (v2, f2) ->
|
|
let v = match v with None -> common_prefix v1 v2 | Some _ -> v in
|
|
(v, t, f1, f2)
|
|
|
|
let parse_two_var_annot :
|
|
int -> string list -> (var_annot option * var_annot option) tzresult =
|
|
fun loc annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc types
|
|
>>? fun () ->
|
|
error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars
|
|
|
|
let parse_destr_annot :
|
|
int ->
|
|
string list ->
|
|
default_accessor:field_annot option ->
|
|
field_name:field_annot option ->
|
|
pair_annot:var_annot option ->
|
|
value_annot:var_annot option ->
|
|
(var_annot option * field_annot option) tzresult =
|
|
fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
|
|
parse_annots loc ~allow_special_var:true annot
|
|
>>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc types
|
|
>>? fun () ->
|
|
get_one_annot loc vars
|
|
>>? fun v ->
|
|
get_one_annot loc fields
|
|
>|? fun f ->
|
|
let default =
|
|
gen_access_annot pair_annot field_name ~default:default_accessor
|
|
in
|
|
let v =
|
|
match v with
|
|
| Some (`Var_annot "%") ->
|
|
field_to_var_annot field_name
|
|
| Some (`Var_annot "%%") ->
|
|
default
|
|
| Some _ ->
|
|
v
|
|
| None ->
|
|
value_annot
|
|
in
|
|
(v, f)
|
|
|
|
let parse_entrypoint_annot :
|
|
int ->
|
|
?default:var_annot option ->
|
|
string list ->
|
|
(var_annot option * field_annot option) tzresult =
|
|
fun loc ?default annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc types
|
|
>>? fun () ->
|
|
get_one_annot loc fields
|
|
>>? fun f ->
|
|
get_one_annot loc vars
|
|
>|? function
|
|
| Some _ as a ->
|
|
(a, f)
|
|
| None -> (
|
|
match default with Some a -> (a, f) | None -> (None, f) )
|
|
|
|
let parse_var_type_annot :
|
|
int -> string list -> (var_annot option * type_annot option) tzresult =
|
|
fun loc annot ->
|
|
parse_annots loc annot >>? classify_annot loc
|
|
>>? fun (vars, types, fields) ->
|
|
error_unexpected_annot loc fields
|
|
>>? fun () ->
|
|
get_one_annot loc vars
|
|
>>? fun v -> get_one_annot loc types >|? fun t -> (v, t)
|