Source file script_ir_annot.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019-2022 Nomadic Labs, <contact@nomadic-labs.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

type var_annot = Var_annot

type type_annot = Type_annot

type field_annot = Field_annot of Non_empty_string.t [@@ocaml.unboxed]

let error_unexpected_annot loc annot =
  match annot with
  | [] -> Result.return_unit
  | _ :: _ -> error (Unexpected_annotation loc)

(* 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 Result.return_unit
    else p s.[i] >>? fun () -> aux (i + 1)
  in
  aux i

let is_allowed_char = function
  | 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9' -> true
  | _ -> false

(* Valid annotation characters as defined by the allowed_annot_char function from lib_micheline/micheline_parser *)
let check_char loc c =
  if is_allowed_char c then Result.return_unit
  else 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

type annot_opt =
  | Field_annot_opt of Non_empty_string.t option
  | Type_annot_opt of type_annot option
  | Var_annot_opt of var_annot option

let at = Non_empty_string.of_string_exn "@"

let parse_annot loc s =
  (* allow empty annotations as wildcards but otherwise only accept
     annotations that start with [a-zA-Z_] *)
  let sub_or_wildcard wrap s =
    match Non_empty_string.of_string s with
    | None -> ok @@ wrap None
    | Some s -> (
        match (s :> string).[0] with
        | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' ->
            (* check that all characters are valid*)
            string_iter (check_char loc) (s :> string) 1 >>? fun () ->
            ok @@ wrap (Some s)
        | _ -> error (Unexpected_annotation loc))
  in
  let len = String.length s in
  if Compare.Int.(len = 0 || len > max_annot_length) then
    error (Unexpected_annotation loc)
  else
    let rest = String.sub s 1 (len - 1) in
    match s.[0] with
    | ':' ->
        sub_or_wildcard
          (fun a ->
            Type_annot_opt
              (Option.map (fun (_ : Non_empty_string.t) -> Type_annot) a))
          rest
    | '@' ->
        sub_or_wildcard
          (fun a ->
            Var_annot_opt
              (Option.map (fun (_ : Non_empty_string.t) -> Var_annot) a))
          rest
    | '%' -> sub_or_wildcard (fun a -> Field_annot_opt a) rest
    | _ -> error (Unexpected_annotation loc)

let parse_annots loc ?(allow_special_var = false) ?(allow_special_field = false)
    l =
  List.map_e
    (function
      | "@%" when allow_special_var -> ok @@ Var_annot_opt (Some Var_annot)
      | "@%%" when allow_special_var -> ok @@ Var_annot_opt (Some Var_annot)
      | "%@" when allow_special_field -> ok @@ Field_annot_opt (Some at)
      | s -> parse_annot loc s)
    l

let opt_field_of_field_opt = function
  | None -> None
  | Some a -> Some (Field_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_opt a, true, _, _, _, _, _
          | Var_annot_opt a, false, [], _, _, _, _ ->
              (true, a :: rv, false, rt, false, rf)
          | Type_annot_opt a, _, _, true, _, _, _
          | Type_annot_opt a, _, _, false, [], _, _ ->
              (false, rv, true, a :: rt, false, rf)
          | Field_annot_opt a, _, _, _, _, true, _
          | Field_annot_opt 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
  | [] -> Result.return_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 check_type_annot 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 >|? fun (_a : type_annot option) -> ()

let check_composed_type_annot 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 : type_annot option) ->
  get_two_annot loc fields >|? fun (_f1, _f2) -> ()

let parse_field_annot :
    Script.location -> string -> Non_empty_string.t option tzresult =
 fun loc annot ->
  if Compare.Int.(String.length annot <= 0) || Compare.Char.(annot.[0] <> '%')
  then Result.return_none
  else
    parse_annot loc annot >|? function
    | Field_annot_opt annot_opt -> annot_opt
    | _ -> None

let is_field_annot loc a = parse_field_annot loc a >|? Option.is_some

let extract_field_annot :
    Script.node -> (Script.node * Non_empty_string.t option) tzresult = function
  | Prim (loc, prim, args, annot) as expr ->
      let rec extract_first acc = function
        | [] -> ok (expr, None)
        | s :: rest -> (
            parse_field_annot loc s >>? function
            | None -> extract_first (s :: acc) rest
            | Some _ as some_field_annot ->
                let annot = List.rev_append acc rest in
                ok (Prim (loc, prim, args, annot), some_field_annot))
      in
      extract_first [] annot
  | expr -> ok (expr, None)

let has_field_annot node =
  extract_field_annot node >|? function
  | _node, Some _ -> true
  | _node, None -> false

let remove_field_annot node =
  extract_field_annot node >|? fun (node, _a) -> node

let extract_entrypoint_annot node =
  extract_field_annot node >|? fun (node, field_annot_opt) ->
  ( node,
    Option.bind field_annot_opt (fun field_annot ->
        Entrypoint.of_annot_lax_opt field_annot) )

let check_var_annot 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_one_annot loc vars >|? fun (_a : var_annot option) -> ()

let check_constr_annot loc annot =
  parse_annots ~allow_special_field:true loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  get_one_annot loc vars >>? fun (_v : var_annot option) ->
  get_one_annot loc types >>? fun (_t : type_annot option) ->
  get_two_annot loc fields >|? fun (_f1, _f2) -> ()

let check_two_var_annot 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 >|? fun (_a1, _a2) -> ()

let check_destr_annot loc 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 : var_annot option) ->
  get_one_annot loc fields >|? fun (_f : field_annot option) -> ()

let check_unpair_annot loc annot =
  parse_annots loc ~allow_special_var:true annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types >>? fun () ->
  get_two_annot loc vars >>? fun (_vcar, _vcdr) ->
  get_two_annot loc fields >|? fun (_f1, _f2) -> ()

let parse_entrypoint_annot loc 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 >|? fun (_v : var_annot option) -> f

let parse_entrypoint_annot_strict loc annot =
  parse_entrypoint_annot loc annot >>? function
  | None -> Ok Entrypoint.default
  | Some (Field_annot a) -> Entrypoint.of_annot_strict ~loc a

let parse_entrypoint_annot_lax loc annot =
  parse_entrypoint_annot loc annot >>? function
  | None -> Ok Entrypoint.default
  | Some (Field_annot annot) -> Entrypoint.of_annot_lax annot

let check_var_type_annot 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 : var_annot option) ->
  get_one_annot loc types >|? fun (_t : type_annot option) -> ()