From 07c8358f5cf099b3cddff30663ed351d867ad366 Mon Sep 17 00:00:00 2001 From: Alan Marko Date: Fri, 4 Oct 2024 14:22:32 +0100 Subject: [PATCH 1/2] feat(lltz_codegen): change of version + type and other fixes for smartpy compatibilityi --- dune-project | 2 +- lib/lltz_codegen/config.ml | 2 +- lib/lltz_codegen/dune | 1 + lib/lltz_codegen/instruction.ml | 102 +- lib/lltz_codegen/lltz_codegen.ml | 158 +- lib/lltz_codegen/type.ml | 43 +- lib/lltz_ir/dsl.ml | 10 +- lib/lltz_ir/dune | 6 +- lib/lltz_ir/expr.ml | 254 +- lib/lltz_ir/free_vars.ml | 27 +- lib/lltz_ir/type.ml | 6 +- lib/lltz_michelson/lltz_michelson.ml | 6 +- lib/michelson/ast.ml | 43 +- lib/michelson/dune | 4 +- .../optimisations/oasis_core/michelson.ml | 3851 +++++++++++++++++ lltz.opam | 2 +- 16 files changed, 4261 insertions(+), 256 deletions(-) create mode 100644 lib/michelson/optimisations/oasis_core/michelson.ml diff --git a/dune-project b/dune-project index d178929..a8ecd52 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.15) +(lang dune 3.7) (name lltz) diff --git a/lib/lltz_codegen/config.ml b/lib/lltz_codegen/config.ml index c002262..569dc2e 100644 --- a/lib/lltz_codegen/config.ml +++ b/lib/lltz_codegen/config.ml @@ -1,4 +1,4 @@ -module I = Michelson.Ast.Instruction +module I = Lltz_michelson.Ast.Instruction module ExtStack = struct type t = diff --git a/lib/lltz_codegen/dune b/lib/lltz_codegen/dune index c83c4e5..464ce00 100644 --- a/lib/lltz_codegen/dune +++ b/lib/lltz_codegen/dune @@ -4,4 +4,5 @@ (libraries core lltz.michelson lltz.ir fmt) (inline_tests) (preprocess (pps ppx_jane)) + (flags (:standard -w -26-27)) ) \ No newline at end of file diff --git a/lib/lltz_codegen/instruction.ml b/lib/lltz_codegen/instruction.ml index 0f10d10..218cc46 100644 --- a/lib/lltz_codegen/instruction.ml +++ b/lib/lltz_codegen/instruction.ml @@ -5,7 +5,7 @@ does not match instruction requirements. *) -module M = Michelson.Ast +module M = Lltz_michelson.Ast module I = M.Instruction module T = M.Type @@ -71,6 +71,26 @@ let dug n stack = | 1 -> [ I.swap ] | n -> [ I.dug_n n ] +(* https://tezos.gitlab.io/michelson-reference/#instr-DIP *) +let dip n (t : t) : t = + fun stack -> + match n with + | 0 -> t stack (* noop *) + | n -> + let rev_left_stack, right_stack = rev_prefix n stack in + let { Config.stack = right_stack; instructions } = t right_stack in + let stack = + Config.ExtStack.apply right_stack ~f:(fun right_stack -> + List.rev_append rev_left_stack right_stack) + in + { Config.stack + ; instructions = + [ (match n with + | 1 -> I.dip instructions + | n -> I.dip_n n instructions) + ] + } + (* https://tezos.gitlab.io/michelson-reference/#instr-DUP, stack is 0-indexed *) let dup n stack = (* n is a index into the stack *) @@ -121,8 +141,42 @@ let remove n stack = | 1 -> I.[ swap; drop ] | n -> I.[ dig_n n; drop ] +let remove_sequence from count stack_init = + (* removes count elements starting from index from *) + let stack_left, stack_right = + match List.split_n stack_init from with + | left, nth :: right -> left, nth :: right + | _ -> + raise_s + [%message + "Instruction.remove_sequence: invalid stack" + (stack_init : SlotStack.t) + (from : int) + (count : int)] + in + if List.length stack_right < count then + raise_s + [%message + "Instruction.remove_sequence: invalid stack" + (stack_init : SlotStack.t) + (from : int) + (count : int)] + else + let stack = stack_left @ (List.drop stack_right count) in + let instructions = + match count, from with + | 0, _ -> [] + | 1, 0 -> [ I.drop ] + | 1, 1 -> [ I.swap; I.drop ] + | 1, _ -> [ I.dig_n from; I.drop ] + | _ ,0 -> [ I.drop_n count ] + | _ , _-> (dip from (drop count) stack_init).instructions + in + Config.ok stack instructions + (* prim m n instr stack: m elements are consumed from the stack, n elements are produced *) let prim m n instr stack = + (M.pp Format.err_formatter instr); let stack = let left, right = List.split_n stack m in (* split stack into left and right at index m *) @@ -133,7 +187,7 @@ let prim m n instr stack = then raise_s [%message - "Instruction.prim: invalid stack" (stack : SlotStack.t) (m : int) (n : int)]; + "Instruction.prim: invalid stack" (stack : SlotStack.t) (m : int) (n : int) ((M.pp_string instr) : string)]; List.init n ~f:(fun _ -> `Value) @ right in Config.ok stack [ instr ] @@ -264,7 +318,19 @@ module Slot = struct in in_ stack - let collect_all slots = seq (List.map slots ~f:collect) + (*let collect_all slots = seq (List.map slots ~f:collect)*) + + let collect_all slots_seq = + if List.length slots_seq = 0 then + seq [] + else + function stack -> + (*raise_s [%message "Instruction.Slot.collect_all: collect_all invalid stack" (stack : SlotStack.t) (slots_seq : Slot.definable list)]*) + let top_found_slot = SlotStack.find_exn stack (List.hd_exn slots_seq) in + Printf.eprintf "top_found_slot: %d\n" top_found_slot; + remove_sequence top_found_slot (List.length slots_seq) stack + + let let_all slots ~in_ = seq [ def_all slots ~in_; collect_all slots ] (* bind and remove after used*) @@ -295,26 +361,6 @@ module Slot = struct end -(* https://tezos.gitlab.io/michelson-reference/#instr-DIP *) -let dip n (t : t) : t = - fun stack -> - match n with - | 0 -> t stack (* noop *) - | n -> - let rev_left_stack, right_stack = rev_prefix n stack in - let { Config.stack = right_stack; instructions } = t right_stack in - let stack = - Config.ExtStack.apply right_stack ~f:(fun right_stack -> - List.rev_append rev_left_stack right_stack) - in - { Config.stack - ; instructions = - [ (match n with - | 1 -> I.dip instructions - | n -> I.dip_n n instructions) - ] - } - (* https://tezos.gitlab.io/michelson-reference/#instr-UNPAIR, accepts 0 and 1 *) let unpair_n n = (* invariant: pop 1 value, push n *) @@ -330,7 +376,7 @@ let pair_n n = match n with | 0 -> prim 0 1 I.unit | 1 -> noop - | 2 -> prim 2 1 I.pair + | 2 -> prim 2 1 (I.pair ()) | n -> prim n 1 (I.pair_n n) (* https://tezos.gitlab.io/michelson-reference/#instr-GET *) @@ -425,7 +471,7 @@ let failwith stack = let create_contract ~storage ~parameter ~code stack = match stack with | `Value :: `Value :: `Value :: stack -> - Config.ok stack [ I.create_contract storage parameter (code (`Value :: stack)) ] + Config.ok (`Value :: `Value :: stack) [ I.create_contract storage parameter (code (`Value :: stack)) ] | _ -> raise_s [%message "Instruction.create_contract: invalid stack" (stack : SlotStack.t)] @@ -442,7 +488,7 @@ let update = prim 3 1 I.update (* https://tezos.gitlab.io/michelson-reference/#i let add = prim 2 1 I.add (* https://tezos.gitlab.io/michelson-reference/#instr-ADD *) let sub = prim 2 1 I.sub (* https://tezos.gitlab.io/michelson-reference/#instr-SUB *) let mul = prim 2 1 I.mul (* https://tezos.gitlab.io/michelson-reference/#instr-MUL *) -let pair = prim 2 1 I.pair (* https://tezos.gitlab.io/michelson-reference/#instr-PAIR *) +let pair = prim 2 1 (I.pair ()) (* https://tezos.gitlab.io/michelson-reference/#instr-PAIR *) let car = prim 1 1 I.car (* https://tezos.gitlab.io/michelson-reference/#instr-CAR *) let cdr = prim 1 1 I.cdr (* https://tezos.gitlab.io/michelson-reference/#instr-CDR *) let get = prim 2 1 I.get (* https://tezos.gitlab.io/michelson-reference/#instr-GET *) @@ -469,7 +515,7 @@ let ge = prim 1 1 I.ge (* https://tezos.gitlab.io/michelson-reference/#instr-GE let int = prim 1 1 I.int (* https://tezos.gitlab.io/michelson-reference/#instr-INT *) let nil type_ = prim 0 1 (I.nil type_) (* https://tezos.gitlab.io/michelson-reference/#instr-NIL *) let cons = prim 2 1 I.cons (* https://tezos.gitlab.io/michelson-reference/#instr-CONS *) -let debug = ref true +let debug = ref false let next_trace_point = ref (-1) (* Directly using michelson specified via micheline. Can take arbitrary number of args and return a single value. *) @@ -498,7 +544,7 @@ let to_michelson t stack ~debug = instructions) let print_s sexp stack = - if !debug then print_s sexp; + if !debug then Printf.eprintf "%s\n" (Sexp.to_string_hum (sexp)); Config.ok stack [] let trace ?(flag = "") t = diff --git a/lib/lltz_codegen/lltz_codegen.ml b/lib/lltz_codegen/lltz_codegen.ml index 6ff03cd..9afe09a 100644 --- a/lib/lltz_codegen/lltz_codegen.ml +++ b/lib/lltz_codegen/lltz_codegen.ml @@ -20,8 +20,8 @@ module LLTZ = struct end module Michelson = struct - module Ast = Michelson.Ast - module T = Michelson.Ast.Type + module Ast = Lltz_michelson.Ast + module T = Lltz_michelson.Ast.Type end open Instruction @@ -29,14 +29,23 @@ open Tezos_micheline let rec compile_row_types row = match row with - | LLTZ.R.Node nodes -> Type.tuple (List.map nodes ~f:compile_row_types) + | LLTZ.R.Node nodes -> + let annots = List.map nodes ~f:( + fun node -> match node with + | LLTZ.R.Leaf(Some (LLTZ.R.Label value),_) -> Some(value) + | _ -> None) in + Type.tuple (List.map nodes ~f:compile_row_types) ~annots | LLTZ.R.Leaf (_, value) -> convert_type value and compile_row_types_for_or row = match row with | LLTZ.R.Node nodes -> - let converted_types = List.map nodes ~f:compile_row_types in - Type.ors converted_types + let converted_types = List.map nodes ~f:compile_row_types_for_or in + let annots = List.map nodes ~f:( + fun node -> match node with + | LLTZ.R.Leaf(Some (LLTZ.R.Label value),_) -> Some (value) + | _ -> None) in + Type.ors converted_types ~annots | LLTZ.R.Leaf (_, value) -> convert_type value and convert_type (ty : LLTZ.T.t) : Michelson.Ast.t = @@ -80,19 +89,19 @@ and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = match const with | Unit -> Michelson.Ast.Instruction.unit | Bool b -> if b then Michelson.Ast.true_ else Michelson.Ast.false_ - | Nat n -> Michelson.Ast.int (Z.to_int n) - | Int n -> Michelson.Ast.int (Z.to_int n) - | Mutez n -> Michelson.Ast.int (Z.to_int n) + | Nat n -> Michelson.Ast.int_of_z (n) + | Int n -> Michelson.Ast.int_of_z (n) + | Mutez n -> Michelson.Ast.int_of_z (n) | String s -> Michelson.Ast.string s | Key s -> Michelson.Ast.string s | Key_hash s -> Michelson.Ast.string s | Bytes s -> Michelson.Ast.(bytes (Bytes.of_string s)) - | Chain_id s -> Michelson.Ast.string s + | Chain_id s -> Michelson.Ast.(bytes (Bytes.of_string s)) | Address s -> Michelson.Ast.string s | Timestamp s -> Michelson.Ast.string s - | Bls12_381_g1 s -> Michelson.Ast.string s - | Bls12_381_g2 s -> Michelson.Ast.string s - | Bls12_381_fr s -> Michelson.Ast.string s + | Bls12_381_g1 s -> Michelson.Ast.(bytes (Bytes.of_string s)) + | Bls12_381_g2 s -> Michelson.Ast.(bytes (Bytes.of_string s)) + | Bls12_381_fr s -> Michelson.Ast.(bytes (Bytes.of_string s)) | Signature s -> Michelson.Ast.string s ;; @@ -144,9 +153,9 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Eq -> eq | Abs -> abs | Neg -> neg - | Nat -> int + | Nat -> nat | Int -> int - | Bytes -> pack (* Assuming pack handles bytes conversion *) + | Bytes -> bytes | Is_nat -> is_nat | Neq -> neq | Le -> le @@ -157,7 +166,7 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Size -> size | Address -> address | Implicit_account -> implicit_account - | Contract (opt, ty) -> contract (convert_type ty) (* TODO: resolve tag option*) + | Contract (opt, ty) -> contract opt (convert_type ty) | Pack -> pack | Unpack ty -> unpack (convert_type ty) | Hash_key -> hash_key @@ -167,7 +176,7 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Keccak -> keccak | Sha3 -> sha3 | Set_delegate -> set_delegate - | Read_ticket -> Michelson.Ast.seq [read_ticket; pair] + | Read_ticket -> Michelson.Ast.seq [read_ticket; pair ()] | Join_tickets -> join_tickets | Pairing_check -> pairing_check | Voting_power -> voting_power @@ -175,9 +184,9 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Cast ty -> cast (convert_type ty) | Rename opt -> failwith (* TODO: Check why the instruction does not exist. *) | Emit (opt, ty_opt) -> emit opt (Option.map ~f:convert_type ty_opt) - | Failwith -> failwith - | Never -> never - | Pair (opt1, opt2) -> pair (* TODO: resolve tag options*) + | Failwith -> assert false + | Never -> assert false + | Pair (opt1, opt2) -> pair ~left_annot:opt1 ~right_annot:opt2 () | Add -> add | Mul -> mul | Sub -> sub @@ -204,7 +213,7 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | View (name, ty) -> view name (convert_type ty) | Slice -> slice | Update -> update - | Get_and_update -> Michelson.Ast.seq [get_and_update; pair] + | Get_and_update -> Michelson.Ast.seq [get_and_update; pair ()] | Transfer_tokens -> transfer_tokens | Check_signature -> check_signature | Open_chest -> open_chest @@ -229,22 +238,22 @@ let rec compile : LLTZ.E.t -> t = | Assign (Mut_var var, value) -> compile_assign var value | If_bool { condition; if_true; if_false } -> compile_if_bool condition if_true if_false - | If_none { subject; if_none; if_some = {lam_var = Var var, var_type; body = some} } -> + | If_none { subject; if_none; if_some = {lam_var = Var var; body = some} } -> compile_if_none subject if_none (var, some) - | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd, var1_ty; lam_var2 = Var tl, var2_ty; body =nonempty }} -> + | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body =nonempty }} -> compile_if_cons subject if_empty (hd, tl, nonempty) - | If_left { subject; if_left = {lam_var = Var left, left_ty; body =l}; if_right = {lam_var = Var right, right_ty; body = r} } -> + | If_left { subject; if_left = {lam_var = Var left; body =l}; if_right = {lam_var = Var right; body = r} } -> compile_if_left subject (left, l) (right, r) | While { cond; body } -> compile_while cond body - | While_left { cond; body = {lam_var = Var var, var_ty; body=body_lambda} } -> compile_while_left cond var body_lambda expr.type_ + | While_left { cond; body = {lam_var = Var var; body=body_lambda} } -> compile_while_left cond var body_lambda expr.type_ | For { index = Mut_var var; init; cond; update; body } -> compile_for var init cond update body - | For_each { collection; body = {lam_var = Var var, var_ty; body = lambda_body} } -> + | For_each { collection; body = {lam_var = Var var; body = lambda_body} } -> compile_for_each collection var lambda_body - | Map { collection; map = {lam_var = Var var, var_ty; body=lam_body} } -> compile_map collection var lam_body - | Fold_left { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } -> + | Map { collection; map = {lam_var = Var var; body=lam_body} } -> compile_map collection var lam_body + | Fold_left { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> compile_fold_left collection init_body var fold_body - | Fold_right { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } + | Fold_right { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> compile_fold_right collection init_body var fold_body | Let_tuple_in { components; rhs; in_ } -> compile_let_tuple_in components rhs in_ | Tuple row -> compile_tuple row @@ -266,8 +275,7 @@ let rec compile : LLTZ.E.t -> t = | Global_constant hash -> assert false) ] -and compile_contract (input_var: string) (input_ty: LLTZ.T.t) (code: LLTZ.E.t) = - let input_ty = convert_type input_ty in +and compile_contract (input_var: string) (code: LLTZ.E.t) = let code_instr = compile code in seq [ Slot.mock_value; Slot.let_ (`Ident input_var) ~in_:code_instr; ] @@ -291,7 +299,11 @@ and compile_const constant = (* Compile a primitive by compiling its arguments, then applying the primitive to the arguments. *) and compile_prim primitive args = let args_instrs = List.map ~f:compile args in - trace ~flag:((Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive))) (seq (List.rev_append (args_instrs) [ prim (List.length args) 1 (convert_primitive primitive) ])) + match primitive with + | LLTZ.P.Failwith -> seq (List.rev_append (args_instrs) [Instruction.failwith]) + | LLTZ.P.Never -> seq (List.rev_append (args_instrs) [Instruction.never]) + | _ -> + trace ~flag:((Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive))) (seq (List.rev_append (args_instrs) [ prim (List.length args) 1 (convert_primitive primitive) ])) (* Compile a dereference by duplicating the value of the mutable variable on the stack. *) and compile_deref (var : string) = trace ~flag:(String.append "mut_var " var) (Slot.dup (`Ident var)) @@ -417,7 +429,6 @@ and get_tuple_lengths tuple path = (* Expand a tuple expression to a sequence of instructions that get the nth element *) and expand_tuple tuple path = - Printf.printf "tuple: %s\n" (Sexp.to_string_hum (LLTZ.E.sexp_of_t tuple)); Out_channel.flush stdout; let lengths = get_tuple_lengths tuple path in let gets = @@ -441,37 +452,38 @@ and compile_let_tuple_in components rhs in_ = (* Compile lambda expression by compiling the body and creating a lambda instruction. *) and compile_lambda expr = - let Lambda { lam_var = Var var, lam_var_type; body } = expr.desc in - - let lam_var = var, convert_type lam_var_type in - let return_type = convert_type body.type_ in - - let environment = - LLTZ.Free_vars.free_vars_with_types expr - |> Map.map ~f:convert_type - |> Map.to_alist - in - seq - ([ lambda ~environment ~lam_var ~return_type (compile body) ] - @ List.map environment ~f:(fun (ident, _) -> seq [ Slot.dup (`Ident ident); apply ]) - ) + match expr.desc with + | Lambda { lam_var = Var var, lam_var_type; body } -> + let lam_var = var, convert_type lam_var_type in + let return_type = convert_type body.type_ in + let environment = + LLTZ.Free_vars.free_vars_with_types expr + |> Map.map ~f:convert_type + |> Map.to_alist + in + seq + ([ lambda ~environment ~lam_var ~return_type (compile body) ] + @ List.map environment ~f:(fun (ident, _) -> seq [ Slot.dup (`Ident ident); apply ]) + ) + | _ -> raise_s [%message "Lambda expected"] (* Compile lambda-rec expression by compiling the body and creating a lambda-rec instruction. *) and compile_lambda_rec expr = - let Lambda_rec { mu_var = Var mu, mu_type; lambda = {lam_var = Var var, lam_var_type; body} } = expr.desc in - - let lam_var = var, convert_type lam_var_type in - let return_type = convert_type body.type_ in - - let environment = - LLTZ.Free_vars.free_vars_with_types expr - |> Map.map ~f:convert_type - |> Map.to_alist - in - seq - ([ lambda_rec ~environment ~lam_var ~mu ~return_type (compile body) ] - @ List.map environment ~f:(fun (ident, _) -> seq [ Slot.dup (`Ident ident); apply ]) - ) + match expr.desc with + | Lambda_rec { mu_var = Var mu, mu_type; lambda = {lam_var = Var var, lam_var_type; body} } -> + let lam_var = var, convert_type lam_var_type in + let return_type = convert_type body.type_ in + + let environment = + LLTZ.Free_vars.free_vars_with_types expr + |> Map.map ~f:convert_type + |> Map.to_alist + in + seq + ([ lambda_rec ~environment ~lam_var ~mu ~return_type (compile body) ] + @ List.map environment ~f:(fun (ident, _) -> seq [ Slot.dup (`Ident ident); apply ]) + ) + | _ -> raise_s [%message "Lambda_rec expected"] (* Compile an application by compiling a lambda and argument, then applying the EXEC instruction. *) and compile_app abs arg = @@ -489,15 +501,19 @@ and compile_create_contract = let storage_ty = convert_type storage in let param_ty = convert_type param_ty in + Printf.eprintf "param_var: %s\n" param_var; let code_instr = seq[Slot.let_ (`Ident param_var) ~in_:(compile code_body)] in - seq - [ compile delegate - ; compile initial_balance - ; compile initial_storage - ; create_contract ~storage:storage_ty ~parameter:param_ty ~code:(fun stack -> - M.seq (code_instr stack).instructions) - ; pair - ] + Printf.eprintf "woohoo\n"; + trace ~flag:"create_contract" ( + seq + [ compile delegate + ; compile initial_balance + ; compile initial_storage + ; create_contract ~storage:storage_ty ~parameter:param_ty ~code:(fun stack -> + M.seq (code_instr stack).instructions) + ; trace ~flag:"pair woohoo" (pair) + ] + ) (* Compile for-each expression by compiling the collection, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the body. *) and compile_for_each collection var body = @@ -628,9 +644,9 @@ let compile_to_micheline expr stack= let micheline = Michelson.Ast.seq (compiled stack).instructions in micheline -let compile_contract_to_micheline input_var input_ty expr stack= - let compiled = compile_contract input_var input_ty expr in - let micheline = Michelson.Ast.seq (compiled stack).instructions in +let compile_contract_to_micheline input_var expr= + let compiled = compile_contract input_var expr in + let micheline = Michelson.Ast.seq (compiled []).instructions in micheline diff --git a/lib/lltz_codegen/type.ml b/lib/lltz_codegen/type.ml index 475bc25..389f32c 100644 --- a/lib/lltz_codegen/type.ml +++ b/lib/lltz_codegen/type.ml @@ -1,27 +1,32 @@ -module M = Michelson.Ast +module M = Lltz_michelson.Ast module T = M.Type -let tuple types = +let tuple ?(annots = []) types = (* Right-comb encoding of tuple-types *) - match types with - | [] -> T.unit - | [ type_ ] -> type_ - | types -> T.pair types + let rec loop ?(annots = []) types = + match types, annots with + | [], [] -> assert false + | [ type1 ], _ -> type1 + | [], _::_ -> assert false + | [ type1; type2 ], [annot1; annot2] -> T.pair ~annot1 ~annot2 type1 type2 + | [ type1; type2 ], [annot1] -> T.pair ~annot1 type1 type2 + | [ type1; type2 ], _ -> T.pair type1 type2 + | type_ :: types, annot1::tl_annots -> T.pair ~annot1 type_ (loop types ~annots:tl_annots) + | type_ :: types, _ -> T.pair type_ (loop types) + in + loop types ~annots ;; -let rec tuple_left types = - (* Left-comb encoding of tuple-types *) - match types with - | [] -> T.unit - | [ type_ ] -> type_ - | a::b::types -> tuple_left ((T.pair [a;b])::types) - -let ors types = +let ors ?(annots = []) types = (* Right-comb encoding of or-types (not efficient, but cheap) *) - let rec loop = function - | [] | [ _ ] -> assert false - | [ type1; type2 ] -> T.or_ type1 type2 - | type_ :: types -> T.or_ type_ (loop types) + let rec loop ?(annots = []) types = + match types, annots with + | [], [] | [ _ ], [ _ ]| [], _::_ -> assert false + | [ type1; type2 ], [annot1; annot2] -> T.or_ ~annot1 ~annot2 type1 type2 + | [ type1; type2 ], [annot1] -> T.or_ ~annot1 type1 type2 + | [ type1; type2 ], _ -> T.or_ type1 type2 + | type_ :: types, annot1::tl_annots -> T.or_ ~annot1 type_ (loop types ~annots:tl_annots) + | type_ :: types, _ -> T.or_ type_ (loop types) in - loop types + loop types ~annots ;; \ No newline at end of file diff --git a/lib/lltz_ir/dsl.ml b/lib/lltz_ir/dsl.ml index 1e02b4f..fd330d4 100644 --- a/lib/lltz_ir/dsl.ml +++ b/lib/lltz_ir/dsl.ml @@ -136,7 +136,7 @@ let map ?(range = dummy) collection ~map = create ~range (LLTZ.E.Map { collectio | LLTZ.T.List ty1 -> mk_type (LLTZ.T.List map.body.type_) ~range | LLTZ.T.Option ty1 -> mk_type (LLTZ.T.Option map.body.type_) ~range | LLTZ.T.Map (kty, ty1) -> mk_type (LLTZ.T.Map (kty, map.body.type_)) ~range - | _ -> raise_s [%message "Expected list, option, or map type" (collection.type_ : LLTZ.T.t)] + | _ -> raise_s [%message "Expected list, option, or map type" (collection.desc: LLTZ.E.desc) (collection.type_ : LLTZ.T.t)] ) let fold_left ?(range = dummy) collection ~init ~fold = create ~range (LLTZ.E.Fold_left { collection; init; fold }) fold.body.type_ let fold_right ?(range = dummy) collection ~init ~fold = create ~range (LLTZ.E.Fold_right { collection; init; fold }) fold.body.type_ @@ -154,7 +154,7 @@ let match_ ?(range = dummy) subject ~cases = create ~range (LLTZ.E.Match (subjec match leaf with | {lam_var = _; body} -> body.type_ ) - | None -> raise_s [%message "Expected a leaf with lambda" (cases : LLTZ.E.lambda LLTZ.R.t)] + | None -> raise_s [%message "Expected a leaf with lambda" (cases : LLTZ.E.lambda_typed LLTZ.R.t)] ) let raw_michelson ?(range = dummy) michelson args return_ty = create ~range (LLTZ.E.Raw_michelson {michelson; args}) return_ty let create_contract ?(range = dummy) () ~storage ~code ~delegate ~initial_balance ~initial_storage = @@ -368,7 +368,7 @@ let div_ ?(range = dummy) (lhs:Expr.t) (rhs:Expr.t) = (if_none ~range (ediv ~range lhs rhs) ~some:( let var_ty = tuple_ty ~range (Row.Node [Row.Leaf (None, lhs.type_); Row.Leaf(None, rhs.type_)]) in let var_name = Name.create () in - {lam_var=(Var var_name, var_ty ); + {lam_var=Var var_name; body = car (variable ~range (Var var_name) (var_ty ))}) ~none:(failwith ~range (string ~range "DIV by 0"))) @@ -376,7 +376,7 @@ let mod_ ?(range = dummy) (lhs:Expr.t) (rhs:Expr.t) = (if_none ~range (ediv ~range lhs rhs) ~some:( let var_ty = tuple_ty ~range (Row.Node [Row.Leaf (None, lhs.type_); Row.Leaf(None, rhs.type_)]) in let var_name = Name.create () in - {lam_var=(Var var_name, var_ty ); + {lam_var=Var var_name; body = cdr (variable ~range (Var var_name) (var_ty ))}) ~none:(failwith ~range (string ~range "MOD by 0"))) @@ -451,4 +451,4 @@ let convert_list (exprs: LLTZ.E.t list) : LLTZ.E.t Row.t = Row.Node converted_row_leaves let gen_name () = Name.create () -let annon_function var_name var_ty ~body : LLTZ.E.lambda = { lam_var = (Var (var_name), var_ty); body } \ No newline at end of file +let annon_function var_name var_ty ~body : LLTZ.E.lambda = { lam_var = Var (var_name); body } \ No newline at end of file diff --git a/lib/lltz_ir/dune b/lib/lltz_ir/dune index 18babb5..1167ad8 100644 --- a/lib/lltz_ir/dune +++ b/lib/lltz_ir/dune @@ -1,7 +1,9 @@ (library (name lltz_ir) (public_name lltz.ir) - (libraries core octez-libs.micheline grace ppxlib.traverse_builtins) + (libraries core tezos-micheline grace ppxlib.traverse_builtins) (modules dsl expr import lltz_ir primitive row type name free_vars) (preprocess - (pps ppx_jane ppxlib.traverse))) \ No newline at end of file + (pps ppx_jane ppxlib.traverse) + ) + (flags (:standard -w -30-27-28))) \ No newline at end of file diff --git a/lib/lltz_ir/expr.ml b/lib/lltz_ir/expr.ml index bf59ff0..e103808 100644 --- a/lib/lltz_ir/expr.ml +++ b/lib/lltz_ir/expr.ml @@ -34,125 +34,175 @@ module T = struct and binder = var * Type.t and lambda = { - lam_var: binder; + lam_var: var; body: t } + + and lambda_typed = { + lam_var: binder; + body: t; + } and lambda2 = { - lam_var1: binder; - lam_var2: binder; + lam_var1: var; + lam_var2: var; + body: t + } + + and let_in = { + let_var: var; + rhs: t; + in_: t + } + + and lambda_rec = { + mu_var: binder; + lambda: lambda_typed + } + + and app = { + abs: t; + arg: t + } + + and let_mut_in = { + let_var: mut_var; + rhs: t; + in_: t + } + + and if_bool = { + condition: t; + if_true: t; + if_false: t + } + + and if_none = { + subject: t; + if_none: t; + if_some: lambda + } + + and if_cons = { + subject: t; + if_empty: t; + if_nonempty: lambda2 + } + + and if_left = { + subject: t; + if_left: lambda; + if_right: lambda + } + + and while_ = { + cond: t; + body: t + } + + and while_left = { + cond: t; + body: lambda + } + + and for_ = { + index: mut_var; + init: t; + cond: t; + update: t; body: t } + and for_each = { + collection: t; + body: lambda + } + + and map_ = { + collection: t; + map: lambda + } + + and fold_left = { + collection: t; + init: t; + fold: lambda + } + + and fold_right = { + collection: t; + init: t; + fold: lambda + } + + and let_tuple_in = { + components: var list; + rhs: t; + in_: t + } + + and update = { + tuple: t; + component: Row.Path.t; + update: t + } + + and raw_michelson = { + michelson: (micheline[@sexp.opaque] [@equal.ignore] [@compare.ignore]); + args: t list + } + + and global_constant = { + hash: string + } + + and create_contract = { + storage: Type.t; + code: lambda_typed; + delegate: t; + initial_balance: t; + initial_storage: t + } + and desc = (* basic lambda calculus w/ primitives + constants *) | Variable of var - | Let_in of - { let_var : var - ; rhs : t - ; in_ : t - } - | Lambda of lambda - | Lambda_rec of - { mu_var : binder - ; lambda : lambda - } - | App of - { abs : t - ; arg : t - } - | Const of constant - | Prim of Primitive.t * t list + | Let_in of let_in + | Lambda of lambda_typed + | Lambda_rec of lambda_rec + | App of app + | Const of constant + | Prim of Primitive.t * t list (* mutability *) - | Let_mut_in of - { let_var : mut_var - ; rhs : t - ; in_ : t - } - | Deref of mut_var - | Assign of mut_var * t - (* low-level control flow (conditional) *) - | If_bool of - { condition : t - ; if_true : t - ; if_false : t - } - | If_none of - { subject : t - ; if_none : t - ; if_some : lambda - } - | If_cons of - { subject : t - ; if_empty : t - ; if_nonempty : lambda2 - } - | If_left of - { subject : t - ; if_left : lambda - ; if_right : lambda - } + | Let_mut_in of let_mut_in + | Deref of mut_var + | Assign of mut_var * t + (* low-level control flow (conditional) *) + | If_bool of if_bool + | If_none of if_none + | If_cons of if_cons + | If_left of if_left (* low-level control flow (iterative) *) - | While of - { cond : t - ; body : t - } - | While_left of - { cond : t - ; body : lambda - } - | For of - { index : mut_var - ; init : t - ; cond : t - ; update : t - ; body : t - } - | For_each of - { collection : t - ; body : lambda - } + | While of while_ + | While_left of while_left + | For of for_ + | For_each of for_each (* high-level control flow (iterative) *) - | Map of - { collection : t - ; map : lambda - } - | Fold_left of - { collection : t - ; init : t - ; fold : lambda - } - | Fold_right of - { collection : t - ; init : t - ; fold : lambda - } + | Map of map_ + | Fold_left of fold_left + | Fold_right of fold_right (* tuples *) - | Let_tuple_in of - { components : var list - ; rhs : t - ; in_ : t - } - | Tuple of t Row.t - | Proj of t * Row.Path.t - | Update of - { tuple : t - ; component : Row.Path.t - ; update : t - } + | Let_tuple_in of let_tuple_in + | Tuple of t Row.t + | Proj of t * Row.Path.t + | Update of update (* sums *) | Inj of Type.t Row.Context.t * t - | Match of t * lambda Row.t + | Match of t * lambda_typed Row.t (* tezos specific *) - | Raw_michelson of { michelson: (micheline[@sexp.opaque] [@equal.ignore] [@compare.ignore]); args: t list } - | Global_constant of { hash: string } - | Create_contract of - { storage : Type.t - ; code : lambda - ; delegate : t - ; initial_balance : t - ; initial_storage : t - } + | Raw_michelson of raw_michelson + | Global_constant of global_constant + | Create_contract of create_contract [@@deriving sexp, equal, compare, traverse] end diff --git a/lib/lltz_ir/free_vars.ml b/lib/lltz_ir/free_vars.ml index 53410a6..0a9df91 100644 --- a/lib/lltz_ir/free_vars.ml +++ b/lib/lltz_ir/free_vars.ml @@ -12,18 +12,25 @@ end let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = let empty = String.Map.empty in + let () = Printexc.record_backtrace true in + (* Merge two maps, ensuring consistent types for identical variables *) let merge fvs1 fvs2 = Map.merge_skewed fvs1 fvs2 ~combine:(fun ~key:ident type1 type2 -> if LLTZ.T.equal type1 type2 then type1 else + try raise_s [%message "free_vars_with_types: inconsistent types in free variables" (ident : string) (type1 : LLTZ.T.t) - (type2 : LLTZ.T.t)] + (type2 : LLTZ.T.t) + ] + with e -> let backtrace = Printexc.get_backtrace () in + Printf.eprintf "An error occurred: %s\nBacktrace:\n%s\n" ((Exn.to_string e)) backtrace; + exit 1 ) in @@ -79,19 +86,19 @@ let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = | If_bool { condition; if_true; if_false } -> merge_all [loop condition bound_vars; loop if_true bound_vars; loop if_false bound_vars] - | If_none { subject; if_none; if_some = { lam_var = Var var, var_type; body } } -> + | If_none { subject; if_none; if_some = { lam_var = Var var; body } } -> let subject_fvs = loop subject bound_vars in let if_none_fvs = loop if_none bound_vars in let some_fvs = loop body (var :: bound_vars) in merge_all [subject_fvs; if_none_fvs; some_fvs] - | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd, var1_ty; lam_var2 = Var tl, var2_ty; body } } -> + | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body } } -> let subject_fvs = loop subject bound_vars in let if_empty_fvs = loop if_empty bound_vars in let nonempty_fvs = loop body (hd :: tl :: bound_vars) in merge_all [subject_fvs; if_empty_fvs; nonempty_fvs] - | If_left { subject; if_left = { lam_var = Var left, left_ty; body = l }; if_right = { lam_var = Var right, right_ty; body = r } } -> + | If_left { subject; if_left = { lam_var = Var left; body = l }; if_right = { lam_var = Var right; body = r } } -> let subject_fvs = loop subject bound_vars in let left_fvs = loop l (left :: bound_vars) in let right_fvs = loop r (right :: bound_vars) in @@ -100,7 +107,7 @@ let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = | While { cond; body } -> merge (loop cond bound_vars) (loop body bound_vars) - | While_left { cond; body = {lam_var = Var var, var_ty; body=body_lambda} } -> + | While_left { cond; body = {lam_var = Var var; body=body_lambda} } -> let cond_fvs = loop cond bound_vars in let body_fvs = loop body_lambda (var :: bound_vars) in merge cond_fvs body_fvs @@ -112,21 +119,21 @@ let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = let body_fvs = loop body (var :: bound_vars) in merge_all [init_fvs; cond_fvs; update_fvs; body_fvs] - | For_each { collection; body = { lam_var = Var var, var_ty; body } } -> + | For_each { collection; body = { lam_var = Var var; body } } -> merge (loop collection bound_vars) (remove (loop body (var :: bound_vars)) [var]) - | Map { collection; map = {lam_var = Var var, var_ty; body=lam_body} } -> + | Map { collection; map = {lam_var = Var var; body=lam_body} } -> let collection_fvs = loop collection bound_vars in let body_fvs = loop lam_body (var :: bound_vars) in merge collection_fvs body_fvs - | Fold_left { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } -> + | Fold_left { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> let collection_fvs = loop collection bound_vars in let init_fvs = loop init_body bound_vars in let fold_fvs = loop fold_body (var :: bound_vars) in merge_all [collection_fvs; init_fvs; fold_fvs] - | Fold_right { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } -> + | Fold_right { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> let collection_fvs = loop collection bound_vars in let init_fvs = loop init_body bound_vars in let fold_fvs = loop fold_body (var :: bound_vars) in @@ -162,6 +169,8 @@ let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = let initial_balance_fvs = loop initial_balance bound_vars in let initial_storage_fvs = loop initial_storage bound_vars in merge_all [code_body_fvs; delegate_fvs; initial_balance_fvs; initial_storage_fvs] + + | Global_constant _ -> assert false and compile_row_free_vars_with_types row bound_vars = match row with diff --git a/lib/lltz_ir/type.ml b/lib/lltz_ir/type.ml index 4a699ba..45d1c46 100644 --- a/lib/lltz_ir/type.ml +++ b/lib/lltz_ir/type.ml @@ -7,6 +7,8 @@ module T = struct ; range : Range.t } + and sapling_state = { memo : int } + and desc = (* sum and product types *) | Tuple of t Row.t @@ -35,8 +37,8 @@ module T = struct | Key_hash | Signature | Operation - | Sapling_state of { memo : int } - | Sapling_transaction of { memo : int } + | Sapling_state of sapling_state + | Sapling_transaction of sapling_state | Never | Bls12_381_g1 | Bls12_381_g2 diff --git a/lib/lltz_michelson/lltz_michelson.ml b/lib/lltz_michelson/lltz_michelson.ml index d01eeab..7eb3b59 100644 --- a/lib/lltz_michelson/lltz_michelson.ml +++ b/lib/lltz_michelson/lltz_michelson.ml @@ -79,9 +79,9 @@ and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = match const with | Unit -> Michelson.Ast.Instruction.unit | Bool b -> if b then Michelson.Ast.true_ else Michelson.Ast.false_ - | Nat n -> Michelson.Ast.int (Z.to_int n) - | Int n -> Michelson.Ast.int (Z.to_int n) - | Mutez n -> Michelson.Ast.int (Z.to_int n) + | Nat n -> Michelson.Ast.int_of_z (n) + | Int n -> Michelson.Ast.int_of_z (n) + | Mutez n -> Michelson.Ast.int_of_z (n) | String s -> Michelson.Ast.string s | Key s -> Michelson.Ast.string s | Key_hash s -> Michelson.Ast.string s diff --git a/lib/michelson/ast.ml b/lib/michelson/ast.ml index fa0c4b8..0570c19 100644 --- a/lib/michelson/ast.ml +++ b/lib/michelson/ast.ml @@ -626,10 +626,13 @@ let pp ppf t = t |> Micheline.strip_locations |> printable Prim.to_string |> print_expr ppf ;; +let pp_string t = Format.asprintf "%a" pp t + (* "Smart constructors" *) let seq ts : t = Seq ((), ts) let prim ?(arguments = []) ?(annot = []) prim : t = Prim ((), prim, arguments, annot) let int n : t = Int ((), Z.of_int n) +let int_of_z z : t = Int ((), z) let string str : t = String ((), str) let bytes str : t = Bytes ((), str) let true_ : t = prim (C True) @@ -658,13 +661,26 @@ module Type = struct let never = prim (T Never) let operation = prim (T Operation) let option ty = prim ~arguments:[ ty ] (T Option) - let or_ t1 t2 = prim ~arguments:[ t1; t2 ] (T Or) - - let pair ts = + let or_ ?(annot1 = None) ?(annot2 = None) t1 t2 = + match annot1, annot2 with + | None, None -> prim ~arguments:[ t1; t2 ] (T Or) + | Some a1, None -> prim ~annot:[a1] ~arguments:[ t1; t2 ] (T Or) + | None, Some _ -> assert false + | Some a1, Some a2 -> prim ~annot:[a1; a2] ~arguments:[ t1; t2 ] (T Or) + + let pair ?(annot1 = None) ?(annot2 = None) t1 t2 = + match annot1, annot2 with + | None, None -> prim ~arguments:[ t1; t2 ] (T Pair) + | Some a1, None -> prim ~annot:[a1] ~arguments:[ t1; t2 ] (T Pair) + | None, Some _ -> assert false + | Some a1, Some a2 -> prim ~annot:[a1; a2] ~arguments:[ t1; t2 ] (T Pair) + + let pair_n ts = assert (List.length ts >= 2); prim ~arguments:ts (T Pair) ;; + let sampling_state n = prim ~arguments:[ n ] (T Sapling_state) let sapling_transaction n = prim ~arguments:[ n ] (T Sapling_transaction) let set cty = prim ~arguments:[ cty ] (T Set) @@ -691,6 +707,7 @@ module Instruction = struct let apply = prim (I Apply) let balance = prim (I Balance) let blake2b = prim (I Blake2b) + let bytes = prim (I Bytes) let car = prim (I Car) let cast ty = prim ~arguments:[ ty ] (I Cast) let cdr = prim (I Cdr) @@ -699,8 +716,8 @@ module Instruction = struct let compare = prim (I Compare) let concat = prim (I Concat) let cons = prim (I Cons) - let contract ty = prim ~arguments:[ ty ] (I Contract) - let create_contract ty1 ty2 instr1 = prim ~arguments:[ ty1; ty2; instr1 ] (I Create_contract) (*Any reason why this was just Contract before?*) + let contract annot ty = prim ~annot:(match annot with | None -> [] | Some a -> [a]) ~arguments:[ ty ] (I Contract) + let create_contract storage parameter instr1 = prim ~arguments:[ parameter; storage; instr1 ] (I Create_contract) (*Any reason why this was just Contract before?*) let dig_n n = prim ~arguments:[ int n ] (I Dig) let dip instr = prim ~arguments:[ seq instr ] (I Dip) let dip_n n instr = prim ~arguments:[ int n; seq instr ] (I Dip) @@ -713,9 +730,9 @@ module Instruction = struct let emit opt ty_opt = match opt, ty_opt with | None, None -> prim (I Emit) - | Some s, None -> prim ~arguments:[ string s ] (I Emit) + | Some s, None -> prim ~annot:[s] (I Emit) | None, Some ty -> prim ~arguments:[ ty ] (I Emit) - | Some s, Some ty -> prim ~arguments:[ string s; ty ] (I Emit) + | Some s, Some ty -> prim ~annot:[s] ~arguments:[ty ] (I Emit) let empty_big_map kty vty = prim ~arguments:[ kty; vty ] (I Empty_big_map) let empty_map kty vty = prim ~arguments:[ kty; vty ] (I Empty_map) let empty_set cty = prim ~arguments:[ cty ] (I Empty_set) @@ -760,7 +777,12 @@ module Instruction = struct let open_chest = prim (I Open_chest) let or_ = prim (I Or) let pack = prim (I Pack) - let pair = prim (I Pair) + let pair ?(left_annot=None) ?(right_annot=None) () = + match left_annot, right_annot with + | None, None -> prim (I Pair) + | Some l, None -> prim ~annot:[l] (I Pair) + | None, Some r -> prim ~annot:[r] (I Pair) + | Some l, Some r -> prim ~annot:[l; r] (I Pair) let pair_n n = prim ~arguments:[ int n ] (I Pair) let pairing_check = prim (I Pairing_check) let push ty x = prim ~arguments:[ ty; x ] (I Push) @@ -772,7 +794,7 @@ module Instruction = struct let self opt = match opt with | None -> prim (I Self) - | Some s -> prim ~arguments:[ string s ] (I Self) + | Some s -> prim ~annot:[ s ] (I Self) let self_address = prim (I Self_address) let sender = prim (I Sender) let set_delegate = prim (I Set_delegate) @@ -801,6 +823,7 @@ module Instruction = struct let voting_power = prim (I Voting_power) let xor = prim (I Xor) let int = prim (I Int) + let nat = prim (I Nat) (*Sequence*) (*Empty sequence*) @@ -816,7 +839,7 @@ module Contract = struct let dummy code = { parameter = Type.unit ; storage = Type.unit - ; code = seq Instruction.([ drop ] @ code @ [ drop; unit; nil Type.operation; pair ]) + ; code = seq Instruction.([ drop ] @ code @ [ drop; unit; nil Type.operation; pair ()]) } ;; diff --git a/lib/michelson/dune b/lib/michelson/dune index 74abe44..ebaf92c 100644 --- a/lib/michelson/dune +++ b/lib/michelson/dune @@ -1,10 +1,10 @@ (library - (name michelson) + (name lltz_michelson) (public_name lltz.michelson) (inline_tests) (libraries core - octez-libs.micheline + tezos-micheline ) (preprocess (pps ppx_jane))) \ No newline at end of file diff --git a/lib/michelson/optimisations/oasis_core/michelson.ml b/lib/michelson/optimisations/oasis_core/michelson.ml new file mode 100644 index 0000000..31b32b9 --- /dev/null +++ b/lib/michelson/optimisations/oasis_core/michelson.ml @@ -0,0 +1,3851 @@ +(* Copyright 2022-2023 Morum LLC, 2019-2022 Smart Chain Arena LLC *) + +open Utils +open Control +include Michelson_base.Type +include Michelson_base.Primitive +include Michelson_base.Protocol +include Michelson_base.Typing +open Printf + +let full_types_and_tags = false + +let cata_mtype_stripped f = + cata_mtype (fun ?annot_type:_ ?annot_variable:_ x -> f x) + +let has_missing_type ~path = + cata_mtype_stripped (function + | MT_var t -> + [Printf.sprintf "Missing type in %s (unknown type variable: %s)" path t] + | x -> fold_mtype_f ( @ ) [] x) + +let remove_annots = + cata_mtype_stripped (function + | MT2 (Pair _, fst, snd) -> mt_pair fst snd + | MT2 (Or _, left, right) -> mt_or left right + | x -> mk_mtype x) + +type ad_step = + | A + | D +[@@deriving eq, ord, show {with_path = false}] + +type tezos_int = Bigint.t [@@deriving eq, ord, show {with_path = false}] + +type stack = + | Stack_ok of mtype list + | Stack_failed +[@@deriving eq, ord, show {with_path = false}] + +type 'instr view = { + name : string + ; pure : bool + ; doc : string + ; tparameter : mtype option + ; treturn : mtype + ; onchain_code : 'instr option + ; offchain_code : 'instr +} +[@@deriving eq, ord, show {with_path = false}, map, fold] + +type ('i, 'literal) instr_f = + | MI0 of mtype prim0 + | MI1 of mtype prim1 + | MI1_fail of prim1_fail + | MI2 of mtype prim2 + | MI3 of prim3 + | MIerror of string + | MIcomment of string list + | MImich of { + name : string + ; parsed : Micheline.t + ; typesIn : mtype list + ; typesOut : mtype list + } + | MIdip of 'i + | MIdipn of int * 'i + | MIloop of 'i + | MIloop_left of 'i + | MIiter of 'i + | MImap of 'i + | MIdrop + | MIdropn of int + | MIdup of int + | MIdig of int + | MIdug of int + | MIif of 'i * 'i + | MIif_left of 'i * 'i + | MIif_none of 'i * 'i + | MIif_cons of 'i * 'i + | MIpush of mtype * 'literal + | MIseq of 'i list + | MIswap + | MIunpair of bool list + | MIpairn of int + | MIfield of ad_step list + | MIsetField of ad_step list + | MIlambda of mtype * mtype * 'i + | MIlambda_rec of mtype * mtype * 'i + | MIcreate_contract of { + tparameter : mtype * string option + ; tstorage : mtype + ; code : 'i + ; views : 'i view list + } + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved +[@@deriving eq, ord, show {with_path = false}, map, fold] + +type ('instr, 'literal) literal_f = + | Int of tezos_int + | Bool of bool + | String of string + | Bytes of string + | Unit + | Pair of 'literal * 'literal + | None_ + | Left of 'literal + | Right of 'literal + | Some_ of 'literal + | Seq of 'literal list + | Elt of ('literal * 'literal) + | Instr of 'instr + | Lambda_rec of 'instr + | AnyMap of ('literal * 'literal) list + | Constant of string +[@@deriving eq, ord, show {with_path = false}, map, fold] + +let sequence_literal_f = + let open Result in + function + | (Int _ | Bool _ | String _ | Bytes _ | Unit | None_ | Constant _) as l -> + Ok l + | Pair (x, y) -> map2 (fun x y -> Pair (x, y)) x y + | Left x -> map (fun x -> Left x) x + | Right x -> map (fun x -> Right x) x + | Some_ x -> map (fun x -> Some_ x) x + | Seq xs -> map (fun x -> Seq x) (sequence_list xs) + | Elt (x, y) -> map2 (fun x y -> Elt (x, y)) x y + | AnyMap xs -> map (fun x -> AnyMap x) (map_list (uncurry (map2 pair)) xs) + | Instr x -> map (fun x -> Instr x) x + | Lambda_rec x -> map (fun x -> Lambda_rec x) x + +let sequence_view ({onchain_code; offchain_code} as view) = + let open Result in + let+ onchain_code = sequence_option onchain_code + and+ offchain_code = offchain_code in + {view with onchain_code; offchain_code} + +let sequence_instr_f = + let open Result in + function + | MIdip x -> map (fun x -> MIdip x) x + | MIdipn (n, x) -> map (fun x -> MIdipn (n, x)) x + | MIloop x -> map (fun x -> MIloop x) x + | MIloop_left x -> map (fun x -> MIloop_left x) x + | MIiter x -> map (fun x -> MIiter x) x + | MImap x -> map (fun x -> MImap x) x + | MIif (i1, i2) -> map2 (fun i1 i2 -> MIif (i1, i2)) i1 i2 + | MIif_left (i1, i2) -> map2 (fun i1 i2 -> MIif_left (i1, i2)) i1 i2 + | MIif_none (i1, i2) -> map2 (fun i1 i2 -> MIif_none (i1, i2)) i1 i2 + | MIif_cons (i1, i2) -> map2 (fun i1 i2 -> MIif_cons (i1, i2)) i1 i2 + | MIlambda (t1, t2, i) -> map (fun x -> MIlambda (t1, t2, x)) i + | MIlambda_rec (t1, t2, i) -> map (fun x -> MIlambda_rec (t1, t2, x)) i + | MIcreate_contract {tparameter; tstorage; code; views} -> + let+ code = code + and+ views = map_list sequence_view views in + MIcreate_contract {tparameter; tstorage; code; views} + | MIseq is -> map (fun is -> MIseq is) (sequence_list is) + | MIpush (t, l) -> map (fun l -> MIpush (t, l)) l + | ( MI0 _ | MI1 _ | MI1_fail _ | MI2 _ + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MIdrop + | MIswap + | MIerror _ + | MIcomment _ + | MImich _ + | MIdropn _ + | MIdup _ + | MIdig _ + | MIdug _ + | MIunpair _ + | MIpairn _ + | MIfield _ + | MIsetField _ + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved ) as instr -> return instr + +type instr = {instr : (instr, literal) instr_f} + +and literal = {literal : (instr, literal) literal_f} +[@@deriving eq, ord, show {with_path = false}, map, fold] + +type ('i, 'l) alg = { + f_instr : ('i, 'l) instr_f -> 'i + ; f_literal : ('i, 'l) literal_f -> 'l +} + +let cata {f_instr; f_literal} = + let rec cata_instr {instr} = + f_instr (map_instr_f cata_instr cata_literal instr) + and cata_literal {literal} = + f_literal (map_literal_f cata_instr cata_literal literal) + in + (cata_instr, cata_literal) + +let cata_instr alg = fst (cata alg) + +let cata_literal alg = snd (cata alg) + +module MLiteral = struct + let compare x y = compare_literal x y + + let int i = {literal = Int i} + + let small_int i = {literal = Int (Bigint.of_int i)} + + let bool x = {literal = Bool x} + + let string x = {literal = String x} + + let bytes x = {literal = Bytes x} + + let unit = {literal = Unit} + + let left x = {literal = Left x} + + let right x = {literal = Right x} + + let some x = {literal = Some_ x} + + let pair x1 x2 = {literal = Pair (x1, x2)} + + let none = {literal = None_} + + let list xs = {literal = Seq xs} + + let set xs = {literal = Seq (Base.List.dedup_and_sort ~compare xs)} + + let seq xs = {literal = Seq xs} + + let elt k v = {literal = Elt (k, v)} + + let mk_map xs = + { + literal = + AnyMap + (Base.List.dedup_and_sort + ~compare:(fun (k1, _) (k2, _) -> compare k1 k2) + xs) + } + + let sapling_empty_state = seq [] + + let constant hash = {literal = Constant hash} + + let instr body = {literal = Instr body} + + let lambda_rec body = {literal = Lambda_rec body} + + let rec to_michelson_string instr_to_string ~protect : literal -> string = + let continue ~protect = to_michelson_string instr_to_string ~protect in + let open Printf in + let prot ~protect s = if protect then sprintf "(%s)" s else s in + fun {literal} -> + match literal with + | Int i -> Big_int.string_of_big_int i + | Unit -> "Unit" + | String s -> sprintf "%S" s + | Bool true -> "True" + | Bool false -> "False" + | Pair (l, r) -> + prot ~protect + (sprintf "Pair %s %s" (continue ~protect:true l) + (continue ~protect:true r)) + | None_ -> "None" + | Left l -> prot ~protect (sprintf "Left %s" (continue ~protect:true l)) + | Right l -> prot ~protect (sprintf "Right %s" (continue ~protect:true l)) + | Some_ l -> prot ~protect (sprintf "Some %s" (continue ~protect:true l)) + | Bytes string_bytes -> "0x" ^ Hex.(show (of_string string_bytes)) + | Seq xs -> + sprintf "{%s}" + (String.concat "; " + (List.filter_map + (fun x -> + let x = continue ~protect:false x in + if x = "" then None else Some x) + xs)) + | AnyMap xs -> + let f (k, v) = {literal = Elt (k, v)} in + let xs = {literal = Seq (List.map f xs)} in + continue ~protect xs + | Elt (k, v) -> + sprintf "Elt %s %s" (continue ~protect:true k) + (continue ~protect:true v) + | Instr i -> instr_to_string i + | Lambda_rec i -> + prot ~protect (sprintf "Lambda_rec %s" (instr_to_string i)) + | Constant s -> prot ~protect (sprintf "constant %S" s) + + let to_michelson_string = to_michelson_string ~protect:true +end + +let string_of_ad_path p = + let f = function + | A -> "A" + | D -> "D" + in + String.concat "" (List.map f p) + +let insert_field_annot a e = + let open Sexplib.Sexp in + match a with + | None | Some "" -> e + | Some a -> ( + let a = Atom ("%" ^ a) in + match e with + | Atom s -> List [Atom s; a] + | List (Atom s :: xs) -> List (Atom s :: a :: xs) + | _ -> assert false) + +let s_expression_of_mtype ?full ?human = + let is_full = full = Some () in + let is_human = human = Some () && not is_full in + let open Sexplib.Sexp in + let f ?annot_type ?annot_variable mt = + let annots = + let get pref = function + | None -> None + | Some s -> Some (Atom (pref ^ s)) + in + List.somes [get ":" annot_type; get "@" annot_variable] + in + let mk = function + | [] -> assert false + | [x] -> x + | xs -> List xs + in + let atom s = mk (Atom s :: annots) in + let call s l = List ((Atom s :: annots) @ l) in + match annot_variable with + | Some a when is_human -> ( + match Base.String.split ~on:'.' a with + | [] -> assert false + | hd :: xs -> + let rec collapse = function + | ("left" | "right") :: xs -> collapse xs + | [last] -> Atom ("@" ^ hd ^ "%" ^ last) + | _ -> Atom ("@" ^ a) + in + collapse xs) + | _ -> ( + match mt with + | MT0 t -> + let s, memo = string_of_type0 t in + Option.cata (atom s) (fun memo -> call s [Atom memo]) memo + | MT1 (t, t1) -> call (string_of_type1 t) [t1] + | MT2 (t, t1, t2) -> + let t, a1, a2 = string_of_type2 t in + call t [insert_field_annot a1 t1; insert_field_annot a2 t2] + | MT_var s -> call "missing_type_conversion" [Atom s]) + in + cata_mtype f + +let buffer_mtype_sexp ~html b = + let rec buffer : Sexplib.Sexp.t -> _ = function + | Atom s -> + Buffer.add_string b (Base.Sexp.Private.mach_maybe_esc_str s) + (* See how this is used in `_opam/lib/sexplib0/sexp.ml` *) + | List [] -> Buffer.add_string b "()" + | List (h :: t) -> + let is_partial = + match h with + | Atom "missing_type_conversion" when html -> true + | _ -> false + in + Buffer.add_char b '('; + if is_partial then Buffer.add_string b ""; + buffer h; + List.iter + (fun elt -> + Buffer.add_char b ' '; + buffer elt) + t; + if is_partial then Buffer.add_string b ""; + Buffer.add_char b ')' + in + buffer + +let buffer_mtype ?full ?human ?protect ?annot ~html b t = + let s_expr = s_expression_of_mtype ?full ?human t in + let s_expr = insert_field_annot annot s_expr in + let sexp_to_string_flat = buffer_mtype_sexp ~html b in + match (protect, s_expr) with + | None, List l -> Misc.buffer_concat b " " sexp_to_string_flat l + | None, Atom a -> Buffer.add_string b (Base.Sexp.Private.mach_maybe_esc_str a) + | Some (), any -> sexp_to_string_flat any + +let string_of_mtype ?full ?human ?protect ?annot ~html t = + Misc.with_buffer (fun b -> + buffer_mtype ?full ?human ?protect ?annot ~html b t) + +let string_of_tparameter ~html (tparameter, annot) = + string_of_mtype ~protect:() ~html ?annot tparameter + +let memo_string_of_mtype_human = + Misc.memoize ~clear_after:1000 (fun _f (full, se) -> + string_of_mtype + ?full:(if full then Some () else None) + ~human:() ~html:false se) + +let memo_string_of_mtype_human ?full t = + memo_string_of_mtype_human (full = Some (), t) + +let string_of_ok_stack ?full stack = + String.concat " : " (List.map (memo_string_of_mtype_human ?full) stack) + +let string_of_stack ?full = function + | Stack_ok stack -> string_of_ok_stack ?full stack + | Stack_failed -> "FAILED" + +let strip_annots {mt} = mk_mtype mt + +let strip_annot_variable {mt; annot_type} = mk_mtype mt ?annot_type + +(** {1 Stack helpers} *) + +type tliteral = { + tliteral : (tinstr, tliteral) literal_f + ; t : mtype Result.t +} + +and tinstr = { + tinstr : (tinstr, tliteral) instr_f + ; stack_in : stack Result.t + ; stack_out : stack Result.t +} +[@@deriving eq, ord, show {with_path = false}] + +type ('i, 'l) talg = { + f_tinstr : + stack_in:stack Result.t + -> stack_out:stack Result.t + -> ('i, 'l) instr_f + -> 'i + ; f_tliteral : t:mtype Result.t -> ('i, 'l) literal_f -> 'l +} + +let tcata {f_tinstr; f_tliteral} = + let rec cata_tinstr {tinstr; stack_in; stack_out} = + f_tinstr ~stack_in ~stack_out (map_instr_f cata_tinstr cata_tliteral tinstr) + and cata_tliteral {tliteral; t} = + f_tliteral ~t (map_literal_f cata_tinstr cata_tliteral tliteral) + in + (cata_tinstr, cata_tliteral) + +let cata_tinstr alg = fst (tcata alg) + +let cata_tliteral alg = snd (tcata alg) + +(* Paramorphisms on instructions and literals. *) +let para_alg ~p_instr ~p_literal = + let f_instr i = ({instr = map_instr_f fst fst i}, p_instr i) in + let f_literal l = ({literal = map_literal_f fst fst l}, p_literal l) in + {f_instr; f_literal} + +let _size_tinstr, _size_tliteral = + let f_tinstr ~stack_in:_ ~stack_out:_ = fold_instr_f ( + ) ( + ) 1 in + let f_tliteral ~t:_ = fold_literal_f ( + ) ( + ) 1 in + tcata {f_tinstr; f_tliteral} + +let erase_types_instr, erase_types_literal = + let f_tinstr ~stack_in:_ ~stack_out:_ instr = {instr} in + let f_tliteral ~t:_ literal = {literal} in + tcata {f_tinstr; f_tliteral} + +type instr_spec = { + name : string + ; rule : + tparameter:mtype * string option + -> mtype list + -> (stack Result.t -> tinstr, mtype -> tliteral) instr_f + -> (tinstr, tliteral) instr_f * stack Result.t + ; commutative : bool + ; arities : (int * int) option +} + +let mk_spec_raw name ?commutative ?arities rule = + {name; commutative = commutative = Some (); arities; rule} + +let mk_spec name ?commutative ?arities rule = + let rule ~tparameter stack instr = + let err msg = + let tinstr = + map_instr_f + (fun x -> x (Error (name ^ " error"))) + (fun _ -> assert false) + instr + in + (tinstr, Error msg) + in + match rule ~tparameter stack instr with + | Some x -> x + | None -> err (name ^ ": unexpected stack") + in + {name; commutative = commutative = Some (); arities; rule} + +let mk_spec_no_sub name ?commutative ?arities rule = + let rule ~tparameter stack instr = + let tinstr = + map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr + in + let stack = rule ~tparameter stack in + Some (tinstr, stack) + in + mk_spec name ?commutative ?arities rule + +let mk_spec_basic name ?commutative ~arities:(a_in, a_out) rule = + let rule ~tparameter:_ stack instr = + match rule stack with + | None -> None + | Some xs -> + assert (List.length xs = a_out); + let tinstr = + map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr + in + let stack = Ok (Stack_ok (xs @ List.drop a_in stack)) in + Some (tinstr, stack) + in + mk_spec name ?commutative ~arities:(a_in, a_out) rule + +let mk_spec_const name t = + mk_spec_basic ~arities:(0, 1) name (fun _ -> Some [t]) + +(** {1 Unification} *) + +let unifiable_types t u = Result.is_ok (unify_types ~tolerant:() t u) + +let unify_stack_elements t1 t2 = + match unify_types ~tolerant:() t1 t2 with + | Ok t -> Some t + | Error _ -> None + +let rec unify_ok_stacks s1 s2 = + match (s1, s2) with + | se1 :: s1, se2 :: s2 -> + Option.map2 + (fun x xs -> x :: xs) + (unify_stack_elements se1 se2) + (unify_ok_stacks s1 s2) + | [], [] -> Some [] + | _ -> None + +let unifiable_ok_stacks t u = Option.is_some (unify_ok_stacks t u) + +let unify_stacks s1 s2 = + match (s1, s2) with + | Stack_ok s1, Stack_ok s2 -> + Option.map (fun x -> Stack_ok x) (unify_ok_stacks s1 s2) + | Stack_failed, s2 -> Some s2 + | s1, Stack_failed -> Some s1 + +let initial_stack ~tparameter ~tstorage = + Stack_ok + [ + mt_pair + {tparameter with annot_variable = Some "parameter"} + {tstorage with annot_variable = Some "storage"} + ] + +(** {1 Michelson instructions} *) + +let mi_seq = + let rule ~tparameter:_ stack = function + | MIseq xs -> + let rec f r stack = function + | [] -> Some (MIseq (List.rev r), stack) + | x :: xs -> + let (x : tinstr) = x stack in + f (x :: r) x.stack_out xs + in + f [] (Ok (Stack_ok stack)) xs + | _ -> assert false + in + mk_spec "(instruction sequence)" rule + +let mi_comment = + let rule ~tparameter:_ stack = Ok (Stack_ok stack) in + mk_spec_no_sub "(comment instruction)" rule + +let mi_error s = + let rule ~tparameter:_ _stack = Error s in + mk_spec_no_sub "(error instruction)" rule + +let mi_failwith = + let rule ~tparameter:_ = function + | _ :: _ -> Ok Stack_failed + | [] -> Error "FAILWITH on empty stack" + in + mk_spec_no_sub "FAILWITH" ~arities:(1, 0) rule + +let mi_never = + let rule ~tparameter:_ = function + | {mt = MT0 Never} :: _ -> Ok Stack_failed + | _ -> Error "NEVER on empty stack" + in + mk_spec_no_sub "NEVER" ~arities:(1, 0) rule + +let mi_ticket = + mk_spec_basic "TICKET" ~arities:(2, 1) (function + | t :: {mt = MT0 Nat} :: _ -> Some [mt_option (mt_ticket t)] + | _ -> None) + +let mi_ticket_deprecated = + mk_spec_basic "TICKET_DEPRECATED" ~arities:(2, 1) (function + | t :: {mt = MT0 Nat} :: _ -> Some [mt_ticket t] + | _ -> None) + +let mi_read_ticket = + mk_spec_basic "READ_TICKET" ~arities:(1, 2) (function + | {mt = MT1 (Ticket, t)} :: _ -> + Some [mt_pair mt_address (mt_pair t mt_nat); mt_ticket t] + | _ -> None) + +let mi_join_tickets = + mk_spec_basic "JOIN_TICKETS" ~arities:(1, 1) (function + | { + mt = + MT2 + ( Pair _ + , ({mt = MT1 (Ticket, _)} as t1) + , ({mt = MT1 (Ticket, _)} as t2) ) + } + :: _ + when unifiable_types t1 t2 -> Some [mt_option t1] + | _ -> None) + +let mi_split_ticket = + mk_spec_basic "SPLIT_TICKET" ~arities:(2, 1) (function + | ({mt = MT1 (Ticket, _)} as t) + :: {mt = MT2 (Pair _, {mt = MT0 Nat}, {mt = MT0 Nat})} + :: _ -> Some [mt_option (mt_pair t t)] + | _ -> None) + +let mi_pairing_check = + mk_spec_basic "PAIRING_CHECK" ~arities:(1, 1) (function + | { + mt = + MT1 + ( List + , { + mt = + MT2 (Pair _, {mt = MT0 Bls12_381_g1}, {mt = MT0 Bls12_381_g2}) + } ) + } + :: _ -> Some [mt_bool] + | _ -> None) + +let cond_aux x y = + let open Result in + let* sx = x.stack_out in + let* sy = y.stack_out in + Option.cata (error "cannot unify branches") ok (unify_stacks sx sy) + +let mi_if = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | {mt = MT0 Bool} :: tail, MIif (x, y) -> + let x = x (Ok (Stack_ok tail)) in + let y = y (Ok (Stack_ok tail)) in + Some (MIif (x, y), cond_aux x y) + | _, MIif _ -> None + | _ -> assert false + in + mk_spec "IF" rule + +let mi_if_none = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | {mt = MT1 (Option, t)} :: tail, MIif_none (x, y) -> + let a = + match t.annot_variable with + | Some v -> v ^ ".some" + | None -> "some" + in + let t = {t with annot_variable = Some a} in + let x = x (Ok (Stack_ok tail)) in + let y = y (Ok (Stack_ok (t :: tail))) in + Some (MIif_none (x, y), cond_aux x y) + | _, MIif_none _ -> None + | _ -> assert false + in + mk_spec "IF_NONE" rule + +let mi_if_left = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | ( {mt = MT2 (Or {annot_left; annot_right}, t, u); annot_variable} :: tail + , MIif_left (x, y) ) -> + let open Option in + let fa v = v ^ "." ^ Option.default "left" annot_left in + let t = {t with annot_variable = Option.map fa annot_variable} in + let fa v = v ^ "." ^ Option.default "right" annot_right in + let u = {u with annot_variable = Option.map fa annot_variable} in + let x = x (Ok (Stack_ok (t :: tail))) in + let y = y (Ok (Stack_ok (u :: tail))) in + return (MIif_left (x, y), cond_aux x y) + | _, MIif_left _ -> None + | _ -> assert false + in + mk_spec "IF_LEFT" rule + +let mi_if_cons = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | {mt = MT1 (List, t)} :: tail, MIif_cons (x, y) -> + let open Option in + let x = x (Ok (Stack_ok (t :: mt_list t :: tail))) in + let y = y (Ok (Stack_ok tail)) in + return (MIif_cons (x, y), cond_aux x y) + | _, MIif_cons _ -> None + | _ -> assert false + in + mk_spec "IF_CONS" rule + +let mi_dip = + let rule ~tparameter:_ stack = function + | MIdip body -> ( + match stack with + | [] -> None + | t :: tail -> ( + let body = body (Ok (Stack_ok tail)) in + let tinstr = MIdip body in + match body.stack_out with + | Ok (Stack_ok tail') -> Some (tinstr, Ok (Stack_ok (t :: tail'))) + | _ -> Some (tinstr, Error "DIP: body error"))) + | _ -> assert false + in + mk_spec "DIP" rule + +let mi_dipn = + let rule ~tparameter:_ stack = function + | MIdipn (n, body) when n <= List.length stack -> ( + assert (n >= 0); + let body = body (Ok (Stack_ok (List.drop n stack))) in + let tinstr = MIdipn (n, body) in + match body.stack_out with + | Ok (Stack_ok stack') -> + Some (tinstr, Ok (Stack_ok (List.take n stack @ stack'))) + | _ -> Some (tinstr, Error "DIP: body error")) + | _ -> assert false + in + mk_spec "DIPn" rule + +let is_hot = + let open Ternary in + let is_hot ?annot_type:_ ?annot_variable:_ mt = + match mt with + | MT1 (Ticket, _) -> Yes + | MT1 (Contract, _) | MT2 (Lambda, _, _) -> No + | MT_var _ -> Maybe + | t -> fold_mtype_f or_ No t + in + cata_mtype is_hot + +let is_duppable t = is_hot t <> Yes + +let mi_dup i = + assert (i >= 1); + let rec get acc n = function + | x :: _ when n = 1 -> + if is_duppable x then Some (x :: List.rev (x :: acc)) else None + | x :: rest -> get (x :: acc) (n - 1) rest + | [] -> None + in + mk_spec_basic "DUP" ~arities:(i, i + 1) (get [] i) + +let mi_dig n = + let rule ~tparameter:_ stack = + match List.split_at_opt n stack with + | None -> Error (sprintf "DIG %i: stack too short" n) + | Some (hi, lo) -> ( + match lo with + | [] -> Error (sprintf "DIG %i: stack too short" n) + | x :: lo -> Ok (Stack_ok ((x :: hi) @ lo))) + in + mk_spec_no_sub "DIG" rule + +let mi_dug n = + let rule ~tparameter:_ = function + | x :: tail -> + if n > List.length tail + then Error (sprintf "DUG %i: stack too short" n) + else + let hi, lo = List.split_at n tail in + Ok (Stack_ok (hi @ (x :: lo))) + | [] -> Error "DUG: empty stack" + in + mk_spec_no_sub "DUG" rule + +let mi_swap = + mk_spec_basic "SWAP" ~arities:(2, 2) (function + | a :: b :: _ -> Some [b; a] + | _ -> None) + +let mi_drop = + mk_spec_basic "DROP" ~arities:(1, 0) (function + | _ :: _ -> Some [] + | [] -> None) + +let mi_dropn n = + mk_spec_basic "DROP" ~arities:(n, 0) (function + | _ :: _ -> Some [] + | [] -> None) + +let unpair_size = List.fold_left (fun acc x -> acc + if x then 1 else 0) 0 + +let unpair_arg xs = + if List.for_all id xs + then string_of_int (List.length xs) + else List.show String.pp (List.map string_of_bool xs) + +let mi_unpair fields = + assert (List.length fields >= 2); + let rec aux acc fields stack = + match (stack, fields) with + | _, [] -> Some (List.rev acc) + | _ :: _, [false] -> Some (List.rev acc) + | se :: _, [true] -> Some (List.rev (se :: acc)) + | {mt = MT2 (Pair _, fst, snd)} :: rest, select :: fields -> + let acc = if select then fst :: acc else acc in + aux acc fields (snd :: rest) + | _ -> None + in + mk_spec_basic "UNPAIR" ~arities:(1, unpair_size fields) (aux [] fields) + +let mi_pairn n = + let rec aux acc n stack = + if n = 0 + then + let rec fold acc = function + | x :: rest -> fold (mt_pair x acc) rest + | [] -> acc + in + match acc with + | [] -> None + | x :: rest -> Some [fold x rest] + else + match stack with + | se :: rest -> aux (se :: acc) (n - 1) rest + | _ -> None + in + mk_spec_basic "PAIR" ~arities:(n, 1) (aux [] n) + +let mi_iter = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | c :: tail, MIiter body -> ( + let el = + match c.mt with + | MT2 (Map, k, v) -> Some (mt_pair k v) + | MT1 ((List | Set), t) -> Some t + | _ -> None + in + match el with + | None -> None + | Some el -> + let body = body (Ok (Stack_ok (el :: tail))) in + let tinstr = MIiter body in + let ok = + match body.stack_out with + | Ok (Stack_ok stack') when unifiable_ok_stacks tail stack' -> + true + | Ok Stack_failed -> true + | _ -> false + in + let s = + if ok then Ok (Stack_ok tail) else Error "ITER: incompatible body" + in + Some (tinstr, s)) + | [], MIiter _ -> None + | _ -> assert false + in + mk_spec "ITER" rule + +let mi_loop = + let rule ~tparameter:_ stack = function + | MIloop body -> ( + match stack with + | {mt = MT0 Bool} :: tail -> ( + let body = body (Ok (Stack_ok tail)) in + let tinstr = MIloop body in + match body.stack_out with + | Ok (Stack_ok ({mt = MT0 Bool} :: tail')) + when unifiable_ok_stacks tail tail' -> + Some (tinstr, Ok (Stack_ok tail)) + | _ -> Some (tinstr, Error "LOOP: incompatible body")) + | _ -> None) + | _ -> assert false + in + mk_spec "LOOP" rule + +let mi_loop_left = + let rule ~tparameter:_ stack = function + | MIloop_left body -> ( + match stack with + | {mt = MT2 (Or _, a, b)} :: tail -> ( + let body = body (Ok (Stack_ok (a :: tail))) in + let tinstr = MIloop_left body in + match body.stack_out with + | Ok (Stack_ok ({mt = MT2 (Pair _, a', b')} :: tail')) + when unifiable_types a a' && unifiable_types b b' + && unifiable_ok_stacks tail tail' -> + Some (tinstr, Ok (Stack_ok (b :: tail))) + | _ -> Some (tinstr, Error "LOOP_LEFT: incompatible body")) + | _ -> None) + | _ -> assert false + in + mk_spec "LOOP_LEFT" rule + +let mi_lambda = + let rule ~tparameter:_ stack = function + | MIlambda (t_in, t_out, body) -> + let body = body (Ok (Stack_ok [t_in])) in + let tinstr = MIlambda (t_in, t_out, body) in + let stack = + let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in + match body.stack_out with + | Ok (Stack_ok [t_out']) when unifiable_types t_out t_out' -> ok + | Ok (Stack_ok _) -> Error "LAMBDA: non-singleton result stack" + | Ok Stack_failed -> ok + | Error s -> Error (Printf.sprintf "lambda stack error %s" s) + in + (tinstr, stack) + | _ -> assert false + in + mk_spec_raw "LAMBDA" rule + +let mi_lambda_rec = + let rule ~tparameter:_ stack = function + | MIlambda_rec (t_in, t_out, body) -> + let body = body (Ok (Stack_ok [t_in; mt_lambda t_in t_out])) in + let tinstr = MIlambda_rec (t_in, t_out, body) in + let stack = + let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in + match body.stack_out with + | Ok (Stack_ok [t_out']) when unifiable_types t_out t_out' -> ok + | Ok (Stack_ok _) -> Error "LAMBDA_REC: non-singleton result stack" + | Ok Stack_failed -> ok + | Error s -> Error (Printf.sprintf "lambda_rec stack error %s" s) + in + (tinstr, stack) + | _ -> assert false + in + mk_spec_raw "LAMBDA_REC" rule + +let mi_map = + let rule ~tparameter:_ stack instr = + match (stack, instr) with + | c :: tail, MImap body -> ( + let wrap_v = + match c.mt with + | MT2 (Map, k, v) -> Some (mt_map k, mt_pair k v) + | MT1 (List, v) -> Some (mt_list, v) + | MT1 (Option, v) -> Some (mt_option, v) + | _ -> None + in + match wrap_v with + | None -> None + | Some (wrap, v) -> ( + let body = body (Ok (Stack_ok (v :: tail))) in + let tinstr = MImap body in + match body.stack_out with + | Ok (Stack_ok (v' :: tail')) when unifiable_ok_stacks tail tail' -> + Some (tinstr, Ok (Stack_ok (wrap v' :: tail))) + | _ -> Some (tinstr, Error "MAP: incompatible body"))) + | [], MImap _ -> None + | _ -> assert false + in + mk_spec "MAP" rule + +let mi_pair ?annot_fst ?annot_snd () = + mk_spec_basic "PAIR" ~arities:(2, 1) (function + | a :: b :: _ -> Some [mt_pair ?annot_fst ?annot_snd a b] + | _ -> None) + +let mi_cons = + mk_spec_basic "CONS" ~arities:(2, 1) (function + | a :: {mt = MT1 (List, a')} :: _ -> ( + match unify_types ~tolerant:() a a' with + | Ok t -> Some [mt_list (strip_annots t)] + | Error _ -> None) + | _ -> None) + +let mi_get = + mk_spec_basic "GET" ~arities:(2, 1) (function + | key :: {mt = MT2 (Map, key', value)} :: _ when unifiable_types key key' -> + Some [mt_option value] + | key :: {mt = MT2 (Big_map, key', value)} :: _ + when unifiable_types key key' -> Some [mt_option value] + | _ -> None) + +let rec get_comb_type n = function + | t when n = 0 -> Some t + | {mt = MT2 (Pair _, fst, _)} when n = 1 -> Some fst + | {mt = MT2 (Pair _, _, snd)} -> get_comb_type (n - 2) snd + | _ -> None + +let mi_getn n = + mk_spec_basic "GET" ~arities:(1, 1) (function + | t :: _ -> Option.map (fun t -> [t]) (get_comb_type n t) + | [] -> None) + +let mi_updaten n = + mk_spec_basic "UPDATE" ~arities:(2, 1) (function + | t1 :: t :: _ -> ( + match get_comb_type n t with + | None -> None + | Some t2 -> if unifiable_types t1 t2 then Some [t] else None) + | _ :: _ | [] -> None) + +let mi_eq = + mk_spec_basic "EQ" ~commutative:() ~arities:(1, 1) (function + | {mt = MT0 Int} :: _ -> Some [mt_bool] + | _ -> None) + +let mi_neq = {mi_eq with name = "NEQ"} + +let mi_lt = {mi_neq with name = "LT"; commutative = false} + +let mi_le = {mi_lt with name = "LE"} + +let mi_gt = {mi_lt with name = "GT"} + +let mi_ge = {mi_lt with name = "GE"} + +let mi_neg = + mk_spec_basic "NEG" ~arities:(1, 1) (function + | {mt = MT0 Nat} :: _ -> Some [mt_int] + | {mt = MT0 Int} :: _ -> Some [mt_int] + | {mt = MT0 Bls12_381_g1} :: _ -> Some [mt_bls12_381_g1] + | {mt = MT0 Bls12_381_g2} :: _ -> Some [mt_bls12_381_g2] + | {mt = MT0 Bls12_381_fr} :: _ -> Some [mt_bls12_381_fr] + | _ -> None) + +let mi_int = + mk_spec_basic "INT" ~arities:(1, 1) (function + | {mt = MT0 Bytes} :: _ -> Some [mt_int] + | {mt = MT0 Nat} :: _ -> Some [mt_int] + | {mt = MT0 Bls12_381_fr} :: _ -> Some [mt_int] + | _ -> None) + +let mi_nat = + mk_spec_basic "NAT" ~arities:(1, 1) (function + | {mt = MT0 Bytes} :: _ -> Some [mt_nat] + | _ -> None) + +let mi_bytes = + mk_spec_basic "BYTES" ~arities:(1, 1) (function + | {mt = MT0 Int} :: _ -> Some [mt_bytes] + | {mt = MT0 Nat} :: _ -> Some [mt_bytes] + | _ -> None) + +let rec is_comparable mtype = + match mtype.mt with + | MT0 + ( Unit + | Bool + | Nat + | Int + | Mutez + | String + | Bytes + | Chain_id + | Timestamp + | Address + | Key + | Key_hash + | Signature + | Never ) -> true + | MT1 (Option, t) -> is_comparable t + | MT2 (Pair _, t1, t2) | MT2 (Or _, t1, t2) -> + is_comparable t1 && is_comparable t2 + | MT0 + ( Operation + | Sapling_state _ + | Sapling_transaction _ + | Bls12_381_g1 + | Bls12_381_g2 + | Bls12_381_fr + | Chest_key + | Chest ) + | MT1 ((List | Set | Contract | Ticket), _) + | MT2 ((Lambda | Map | Big_map), _, _) + | MT_var _ -> false + +let mi_compare = + mk_spec_basic "COMPARE" ~arities:(2, 1) (function + | a :: b :: _ when is_comparable a && is_comparable b && unifiable_types a b + -> Some [mt_int] + | _ -> None) + +let mi_sub = + mk_spec_basic "SUB" ~arities:(2, 1) (function + | {mt = MT0 Int} :: {mt = MT0 Int} :: _ -> Some [mt_int] + | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> Some [mt_int] + | {mt = MT0 Nat} :: {mt = MT0 Int} :: _ -> Some [mt_int] + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_int] + | {mt = MT0 Mutez} :: {mt = MT0 Mutez} :: _ -> Some [mt_mutez] + | {mt = MT0 Timestamp} :: {mt = MT0 Int} :: _ -> Some [mt_timestamp] + | {mt = MT0 Timestamp} :: {mt = MT0 Timestamp} :: _ -> Some [mt_int] + | _ -> None) + +let mi_ediv = + mk_spec_basic "EDIV" ~arities:(2, 1) (function + | {mt = MT0 Int} :: {mt = MT0 Int} :: _ -> + Some [mt_option (mt_pair mt_int mt_nat)] + | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> + Some [mt_option (mt_pair mt_int mt_nat)] + | {mt = MT0 Nat} :: {mt = MT0 Int} :: _ -> + Some [mt_option (mt_pair mt_int mt_nat)] + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> + Some [mt_option (mt_pair mt_nat mt_nat)] + | {mt = MT0 Mutez} :: {mt = MT0 Nat} :: _ -> + Some [mt_option (mt_pair mt_mutez mt_mutez)] + | {mt = MT0 Mutez} :: {mt = MT0 Mutez} :: _ -> + Some [mt_option (mt_pair mt_nat mt_mutez)] + | _ -> None) + +let mi_not ~protocol:_ = + mk_spec_basic "NOT" ~commutative:() ~arities:(1, 1) (function + | {mt = MT0 Bool} :: _ -> Some [mt_bool] + | {mt = MT0 Nat} :: _ -> Some [mt_int] + | {mt = MT0 Int} :: _ -> Some [mt_int] + | {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | _ -> None) + +let mi_and ~protocol:_ = + mk_spec_basic "AND" ~commutative:() ~arities:(2, 1) (function + | {mt = MT0 Bool} :: {mt = MT0 Bool} :: _ -> Some [mt_bool] + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] + | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] + | {mt = MT0 Bytes} :: {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | _ -> None) + +let mi_or ~protocol:_ = + mk_spec_basic "OR" ~commutative:() ~arities:(2, 1) (function + | {mt = MT0 Bool} :: {mt = MT0 Bool} :: _ -> Some [mt_bool] + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] + | {mt = MT0 Bytes} :: {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | _ -> None) + +let mi_xor ~protocol = {(mi_or ~protocol) with name = "XOR"} + +let mi_shift_left ~protocol:_ = + mk_spec_basic "LSL" ~arities:(2, 1) (function + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] + | {mt = MT0 Bytes} :: {mt = MT0 Nat} :: _ -> Some [mt_bytes] + | _ -> None) + +let mi_shift_right ~protocol = {(mi_shift_left ~protocol) with name = "LSR"} + +let mi_unit = mk_spec_const "UNIT" mt_unit + +let mi_nil t = mk_spec_const "NIL" (mt_list t) + +let mi_empty_set t = mk_spec_const "EMPTY_SET" (mt_set t) + +let mi_empty_map k v = mk_spec_const "EMPTY_MAP" (mt_map k v) + +let mi_empty_big_map k v = mk_spec_const "EMPTY_BIG_MAP" (mt_big_map k v) + +let mi_none t = mk_spec_const "NONE" (mt_option t) + +let is_pushable t = + match t.mt with + | MT2 (Big_map, _, _) -> false + | MT1 (Contract, _) -> false + | MT0 Operation -> false + | MT0 (Sapling_state _) -> false + | MT1 (Ticket, _) -> false + | MT0 Unit + | MT0 Bool + | MT0 Nat + | MT0 Int + | MT0 Mutez + | MT0 String + | MT0 Bytes + | MT0 Chain_id + | MT0 Timestamp + | MT0 Address + | MT0 Key + | MT0 Key_hash + | MT0 Signature + | MT0 (Sapling_transaction _) + | MT0 Never + | MT0 Bls12_381_g1 + | MT0 Bls12_381_g2 + | MT0 Bls12_381_fr + | MT0 Chest_key + | MT0 Chest + | MT1 (Option, _) + | MT1 (List, _) + | MT1 (Set, _) + | MT2 (Lambda, _, _) + | MT2 (Map, _, _) + | MT2 (Pair _, _, _) + | MT2 (Or _, _, _) -> true + | MT_var _ -> false + +let mi_push = + let rule ~tparameter:_ stack = function + | MIpush (t, l) -> + let l = l t in + let tinstr = MIpush (t, l) in + let stack = + if is_pushable t + then + match l.t with + | Ok _ -> Ok (Stack_ok (t :: stack)) + | Error e -> Error e + else Error "Type is not pushable" + in + (tinstr, stack) + | _ -> assert false + in + mk_spec_raw "PUSH" ~arities:(0, 1) rule + +let mi_some = + mk_spec_basic "SOME" ~arities:(1, 1) (function + | t :: _ -> Some [mt_option (strip_annots t)] + | [] -> None) + +let mi_left ?annot_left ?annot_right b = + mk_spec_basic "LEFT" ~arities:(1, 1) (function + | a :: _ -> Some [mt_or ?annot_left ?annot_right (strip_annots a) b] + | [] -> None) + +let mi_right ?annot_left ?annot_right a = + mk_spec_basic "RIGHT" ~arities:(1, 1) (function + | b :: _ -> Some [mt_or ?annot_left ?annot_right a (strip_annots b)] + | [] -> None) + +(** Select the part of the type designated by the ad_path. *) +let rec ad_path_in_type ops t = + match (ops, t) with + | [], _ -> Some t + | A :: p, {mt = MT2 (Pair _, fst, _)} -> ad_path_in_type p fst + | D :: p, {mt = MT2 (Pair _, _, snd)} -> ad_path_in_type p snd + | _ :: _, _ -> None + +let mi_field steps = + mk_spec_basic ~arities:(1, 1) + (sprintf "C%sR" (string_of_ad_path steps)) + (function + | t :: _ -> ( + match ad_path_in_type steps t with + | None -> None + | Some t -> Some [t]) + | [] -> None) + +let mi_set_field steps = + mk_spec_basic ~arities:(2, 1) + (sprintf "SET_C%sR" (string_of_ad_path steps)) + (function + | t :: x :: _ -> ( + match ad_path_in_type steps t with + | Some x' when unifiable_types x x' -> Some [t] + | _ -> None) + | _ -> None) + +let mi_update = + mk_spec_basic "UPDATE" ~arities:(3, 1) (function + | k :: {mt = MT0 Bool} :: {mt = MT1 (Set, k')} :: _ -> + Option.map + (fun k -> [mt_set k]) + (Result.get_ok (unify_types ~tolerant:() k k')) + | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Map, k', v')} :: _ -> + Option.map2 + (fun k v -> [mt_map k v]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Big_map, k', v')} :: _ -> + Option.map2 + (fun k v -> [mt_big_map k v]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | _ -> None) + +let mi_get_and_update = + mk_spec_basic "GET_AND_UPDATE" ~arities:(3, 2) (function + | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Map, k', v')} :: _ -> + Option.map2 + (fun k v -> [mt_option v; mt_map k v]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Big_map, k', v')} :: _ -> + Option.map2 + (fun k v -> [mt_option v; mt_big_map k v]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | _ -> None) + +let mi_open_chest = + mk_spec_basic "OPEN_CHEST" ~arities:(3, 1) (function + | {mt = MT0 Chest_key} :: {mt = MT0 Chest} :: {mt = MT0 Nat} :: _ -> + Some [mt_or mt_bytes mt_bool] + | _ -> None) + +let mi_mem = + mk_spec_basic "MEM" ~arities:(2, 1) (function + | k :: {mt = MT1 (Set, k')} :: _ when unifiable_types k k' -> Some [mt_bool] + | k :: {mt = MT2 (Map, k', _)} :: _ when unifiable_types k k' -> + Some [mt_bool] + | k :: {mt = MT2 (Big_map, k', _)} :: _ when unifiable_types k k' -> + Some [mt_bool] + | _ -> None) + +let mi_exec = + mk_spec_basic "EXEC" ~arities:(2, 1) (function + | k :: {mt = MT2 (Lambda, k', v)} :: _ -> + if unifiable_types k k' then Some [v] else None + | _ -> None) + +let mi_apply = + mk_spec_basic "APPLY" ~arities:(2, 1) (function + | k :: {mt = MT2 (Lambda, {mt = MT2 (Pair _, k', k'')}, v)} :: _ + when unifiable_types k k' -> Some [mt_lambda k'' v] + | _ -> None) + +let mi_contract t = + mk_spec_basic "CONTRACT" ~arities:(1, 1) (function + | {mt = MT0 Address} :: _ -> Some [mt_option (mt_contract t)] + | _ -> None) + +let mi_view t = + mk_spec_basic "VIEW" ~arities:(2, 1) (function + | _ :: {mt = MT0 Address} :: _ -> Some [mt_option t] + | _ -> None) + +let mi_cast t = + mk_spec_basic "CAST" ~arities:(1, 1) (function + | t' :: _ when unifiable_types t t' -> Some [t] + | _ -> None) + +let mi_emit t = + let matches t' = + match t with + | None -> true + | Some t -> unifiable_types t t' + in + mk_spec_basic "EMIT" ~arities:(1, 1) (function + | t' :: _ when matches t' -> Some [mt_operation] + | _ -> None) + +let mi_rename annot_variable = + mk_spec_basic "RENAME" ~arities:(1, 1) (function + | t :: _ -> Some [{t with annot_variable}] + | _ -> None) + +let mi_transfer_tokens = + mk_spec_basic "TRANSFER_TOKENS" ~arities:(3, 1) (function + | p :: {mt = MT0 Mutez} :: {mt = MT1 (Contract, p')} :: _ + when unifiable_types p p' -> Some [mt_operation] + | _ -> None) + +let mi_set_delegate = + mk_spec_basic "SET_DELEGATE" ~arities:(1, 1) (function + | {mt = MT1 (Option, {mt = MT0 Key_hash})} :: _ -> Some [mt_operation] + | _ -> None) + +let mi_sapling_verify_update = + mk_spec_basic "SAPLING_VERIFY_UPDATE" ~arities:(2, 1) (function + | {mt = MT0 (Sapling_transaction {memo = m1})} + :: {mt = MT0 (Sapling_state {memo = m2})} + :: _ + when m1 = m2 -> + Some + [mt_option (mt_pair mt_bytes (mt_pair mt_int (mt_sapling_state m1)))] + | _ -> None) + +let mi_concat1 = + mk_spec_basic "CONCAT" ~arities:(1, 1) (function + | {mt = MT1 (List, {mt = MT0 (String | Bytes) as mt})} :: _ -> + Some [mk_mtype mt] + | _ -> None) + +let mi_concat2 = + mk_spec_basic "CONCAT" ~arities:(2, 1) (function + | {mt = MT0 String as mt} :: {mt = MT0 String} :: _ + | {mt = MT0 Bytes as mt} :: {mt = MT0 Bytes} :: _ -> Some [mk_mtype mt] + | _ -> None) + +let mi_concat_unresolved = + let rule ~tparameter stack instr = + let _instr1, r1 = mi_concat1.rule ~tparameter stack instr in + match r1 with + | Ok _ -> (MI1 Concat1, r1) + | Error _ -> + let _instr2, r2 = mi_concat2.rule ~tparameter stack instr in + (MI2 Concat2, r2) + in + {name = "CONCAT"; rule; commutative = false; arities = None} + +let mi_pack = + mk_spec_basic "PACK" ~arities:(1, 1) (function + | t :: _ when is_packable t -> Some [mt_bytes] + | _ -> None) + +let mi_unpack t = + mk_spec_basic "UNPACK" ~arities:(1, 1) (function + | {mt = MT0 Bytes} :: _ when is_packable t -> Some [mt_option t] + | _ -> None) + +let mi_slice = + mk_spec_basic "SLICE" ~arities:(3, 1) (function + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: {mt = MT0 String} :: _ -> + Some [mt_option mt_string] + | {mt = MT0 Nat} :: {mt = MT0 Nat} :: {mt = MT0 Bytes} :: _ -> + Some [mt_option mt_bytes] + | _ -> None) + +let mi_size = + mk_spec_basic "SIZE" ~arities:(1, 1) (function + | { + mt = + ( MT0 String + | MT0 Bytes + | MT1 ((Set | List), _) + | MT2 ((Map | Big_map), _, _) ) + } + :: _ -> Some [mt_nat] + | _ -> None) + +let mi_mich ~name ~types_in ~types_out = + mk_spec_basic name + ~arities:(List.length types_in, List.length types_out) + (fun stack -> + if List.is_prefix equal_mtype types_in stack then Some types_out else None) + +let mi_self = + let rule ~tparameter stack = function + | MI0 (Self ep_name) -> ( + let tinstr = MI0 (Self ep_name) in + let mt_contract t = + {(mt_contract t) with annot_variable = Some "self"} + in + match ep_name with + | None -> + Some (tinstr, Ok (Stack_ok (mt_contract (fst tparameter) :: stack))) + | Some ep_name -> ( + let rec find_ep (t, annot) = + match (t.mt, annot) with + | _, Some a when a = ep_name -> Some t + | MT2 (Or {annot_left; annot_right}, left, right), None -> ( + match find_ep (left, annot_left) with + | Some t -> Some t + | None -> find_ep (right, annot_right)) + | _ -> None + in + match find_ep tparameter with + | None -> None + | Some t -> Some (tinstr, Ok (Stack_ok (mt_contract t :: stack))))) + | _ -> assert false + in + mk_spec "SELF" ~arities:(0, 1) rule + +let mi_address = + mk_spec_basic "ADDRESS" ~arities:(1, 1) (function + | {mt = MT1 (Contract, _)} :: _ -> Some [mt_address] + | _ -> None) + +let mi_implicit_account = + mk_spec_basic "IMPLICIT_ACCOUNT" ~arities:(1, 1) (function + | {mt = MT0 Key_hash} :: _ -> Some [mt_contract mt_unit] + | _ -> None) + +let mi_voting_power = + mk_spec_basic "VOTING_POWER" ~arities:(1, 1) (function + | {mt = MT0 Key_hash} :: _ -> Some [mt_nat] + | _ -> None) + +let typecheck_view ~tstorage ({tparameter; onchain_code; offchain_code} as v) = + let check offchain code = + let stack = + match tparameter with + | None -> + let stack = + if offchain + then Stack_ok [{tstorage with annot_variable = Some "storage"}] + else initial_stack ~tparameter:mt_unit ~tstorage + in + stack + | Some tparameter -> initial_stack ~tparameter ~tstorage + in + code (Ok stack) + in + { + v with + onchain_code = Option.map (check false) onchain_code + ; offchain_code = (check true) offchain_code + } + +let mi_create_contract = + let rule ~tparameter:_ stack = function + | MIcreate_contract {tparameter; tstorage; code; views} -> ( + match stack with + | {mt = MT1 (Option, {mt = MT0 Key_hash})} + :: {mt = MT0 Mutez} + :: storage :: tail -> + let code = + code (Ok (initial_stack ~tparameter:(fst tparameter) ~tstorage)) + in + let views = List.map (typecheck_view ~tstorage) views in + if unifiable_types storage tstorage + then + let tinstr = + MIcreate_contract {tparameter; tstorage; code; views} + in + let stack = Ok (Stack_ok (mt_operation :: mt_address :: tail)) in + Some (tinstr, stack) + else None + | _ -> None) + | _ -> assert false + in + mk_spec "CREATE_CONTRACT" ~arities:(3, 2) rule + +let spec_of_prim0 p = + let mk name = + let t = Michelson_base.Typing.type_prim0 p in + mk_spec_const name t + in + match p with + | Sender -> mk "SENDER" + | Source -> mk "SOURCE" + | Amount -> mk "AMOUNT" + | Balance -> mk "BALANCE" + | Chain_id -> mk "CHAIN_ID" + | Level -> mk "LEVEL" + | Now -> mk "NOW" + | Total_voting_power -> mk "TOTAL_VOTING_POWER" + | Self_address -> mk "SELF_ADDRESS" + | Sapling_empty_state _ -> mk "SAPLING_EMPTY_STATE" + | Nil t -> mi_nil t + | Empty_set t -> mi_empty_set t + | Empty_bigmap (k, v) -> mi_empty_big_map k v + | Empty_map (k, v) -> mi_empty_map k v + | None_ t -> mi_none t + | Unit_ -> mi_unit + | Self _ -> mi_self + +let spec_of_prim1 ~protocol p = + let mk name = + let t1, t = Michelson_base.Typing.type_prim1 p in + let f = function + | x :: _ when unifiable_types x t1 -> Some [t] + | _ -> None + in + mk_spec_basic name ~arities:(1, 1) f + in + match p with + | Hash_key -> mk "HASH_KEY" + | IsNat -> mk "ISNAT" + | Blake2b -> mk "BLAKE2B" + | Sha256 -> mk "SHA256" + | Sha512 -> mk "SHA512" + | Keccak -> mk "KECCAK" + | Sha3 -> mk "SHA3" + | Abs -> mk "ABS" + | Not -> mi_not ~protocol + | Contract (_, t) -> mi_contract t + | Cast t -> mi_cast t + | Emit (_tag, ty) -> mi_emit ty + | Rename a -> mi_rename a + | Concat1 -> mi_concat1 + | Set_delegate -> mi_set_delegate + | Read_ticket -> mi_read_ticket + | Join_tickets -> mi_join_tickets + | Pairing_check -> mi_pairing_check + | Eq -> mi_eq + | Neq -> mi_neq + | Lt -> mi_lt + | Le -> mi_le + | Gt -> mi_gt + | Ge -> mi_ge + | Neg -> mi_neg + | Nat -> mi_nat + | Int -> mi_int + | Bytes -> mi_bytes + | Some_ -> mi_some + | Left (annot_left, annot_right, t) -> mi_left ?annot_left ?annot_right t + | Right (annot_left, annot_right, t) -> mi_right ?annot_left ?annot_right t + | Pack -> mi_pack + | Unpack t -> mi_unpack t + | Getn n -> mi_getn n + | Address -> mi_address + | Implicit_account -> mi_implicit_account + | Voting_power -> mi_voting_power + | Size -> mi_size + | Car | Cdr -> assert false + +let spec_of_prim2 ~protocol p = + let mk ?commutative name = + match Michelson_base.Typing.type_prim2 p with + | [((t1, t2), t)] -> + let f = function + | x1 :: x2 :: _ when unifiable_types x1 t1 && unifiable_types x2 t2 -> + Some [t] + | _ -> None + in + mk_spec_basic name ?commutative ~arities:(2, 1) f + | instances -> + let f = function + | x1 :: x2 :: _ -> ( + match + List.assoc_opt (strip_annots x1, strip_annots x2) instances + with + | None -> None + | Some t -> Some [t]) + | _ -> None + in + mk_spec_basic name ?commutative ~arities:(2, 1) f + in + match p with + | Lsl -> mi_shift_left ~protocol + | Lsr -> mi_shift_right ~protocol + | Add -> mk ~commutative:() "ADD" + | Sub -> mi_sub + | Sub_mutez -> mk "SUB_MUTEZ" + | Mul -> mk "MUL" + | Ediv -> mi_ediv + | Concat2 -> mi_concat2 + | Sapling_verify_update -> mi_sapling_verify_update + | Ticket -> mi_ticket + | Ticket_deprecated -> mi_ticket_deprecated + | Split_ticket -> mi_split_ticket + | Compare -> mi_compare + | Pair (annot_fst, annot_snd) -> mi_pair ?annot_fst ?annot_snd () + | Cons -> mi_cons + | And -> mi_and ~protocol + | Or -> mi_or ~protocol + | Xor -> mi_xor ~protocol + | Get -> mi_get + | Updaten n -> mi_updaten n + | Mem -> mi_mem + | Exec -> mi_exec + | Apply -> mi_apply + | View (_, t) -> mi_view t + +let spec_of_prim3 p = + let mk name = + let t1, t2, t3, t = Michelson_base.Typing.type_prim3 p in + let f = function + | x1 :: x2 :: x3 :: _ + when unifiable_types x1 t1 && unifiable_types x2 t2 + && unifiable_types x3 t3 -> Some [t] + | _ -> None + in + mk_spec_basic name ~arities:(3, 1) f + in + match p with + | Check_signature -> mk "CHECK_SIGNATURE" + | Slice -> mi_slice + | Transfer_tokens -> mi_transfer_tokens + | Update -> mi_update + | Get_and_update -> mi_get_and_update + | Open_chest -> mi_open_chest + +let spec_of_instr ~protocol = function + | MI0 p -> spec_of_prim0 p + | MI1 p -> spec_of_prim1 ~protocol p + | MI2 p -> spec_of_prim2 ~protocol p + | MI3 p -> spec_of_prim3 p + | MI1_fail Failwith -> mi_failwith + | MI1_fail Never -> mi_never + | MIpush _ -> mi_push + | MIconcat1 -> mi_concat1 + | MIconcat2 -> mi_concat2 + | MIconcat_unresolved -> mi_concat_unresolved + | MIswap -> mi_swap + | MIdrop -> mi_drop + | MIdropn n -> mi_dropn n + | MIunpair n -> mi_unpair n + | MIpairn n -> mi_pairn n + | MIfield steps -> mi_field steps + | MIsetField steps -> mi_set_field steps + | MIdup i -> mi_dup i + | MIcreate_contract _ -> mi_create_contract + | MImich {name; typesIn; typesOut} -> + mi_mich ~name ~types_in:typesIn ~types_out:typesOut + | MIdip _ -> mi_dip + | MIdipn _ -> mi_dipn + | MIiter _ -> mi_iter + | MImap _ -> mi_map + | MIloop _ -> mi_loop + | MIloop_left _ -> mi_loop_left + | MIif _ -> mi_if + | MIif_none _ -> mi_if_none + | MIif_left _ -> mi_if_left + | MIif_cons _ -> mi_if_cons + | MIdig n -> mi_dig n + | MIdug n -> mi_dug n + | MIseq _ -> mi_seq + | MIlambda _ -> mi_lambda + | MIlambda_rec _ -> mi_lambda_rec + | MIcomment _ -> mi_comment + | MIerror s -> mi_error s + +let is_commutative ~protocol instr = (spec_of_instr ~protocol instr).commutative + +let name_of_instr ~protocol instr = (spec_of_instr ~protocol instr).name + +(** {1 Type checking} *) + +(* Recognize lists of Elts and lists of Instrs. *) +let sanitize_instr, sanitize_literal = + let f_literal : _ literal_f -> _ = function + | Seq ({literal = Elt _} :: _ as xs) -> + let f = function + | {literal = Elt (k, v)} -> (k, v) + | _ -> failwith "sanitize: Elt followed by non-Elt" + in + {literal = AnyMap (List.map f xs)} + | Seq ({literal = Instr _} :: _ as xs) -> + let f = function + | {literal = Instr i} -> i + | _ -> failwith "sanitize: instruction followed by non-instruction" + in + {literal = Instr {instr = MIseq (List.map f xs)}} + | literal -> {literal} + in + let f_instr instr = {instr} in + cata {f_instr; f_literal} + +(* Match a comb type against the given tuple. *) +let rec match_comb t xs = + match (t.mt, xs) with + | _, [x] -> [(t, x)] + | MT2 (Pair _, fst, snd), x :: xs -> (fst, x) :: match_comb snd xs + | _ -> failwith "match_comb" + +(* Roll a list into a right comb. *) +let rec comb_literal = function + | [x1; x2] -> {tliteral = Pair (x1, x2); t = Result.map2 mt_pair x1.t x2.t} + | x :: xs -> + let xs = comb_literal xs in + {tliteral = Pair (x, xs); t = Result.map2 mt_pair x.t xs.t} + | _ -> assert false + +let typecheck_literal_f ~tparameter:_ (literal : _ literal_f) + (t : mtype Result.t) = + let tliteral' : + (stack Result.t -> tinstr, mtype Result.t -> tliteral) literal_f = + map_literal_f snd snd literal + in + let r = + let open Result in + let* t = map_error (fun _ -> "type error") t in + match (t.mt, tliteral') with + | _, (Constant _ as l) -> return l + | MT0 Unit, (Unit as l) + | MT0 Bool, (Bool _ as l) + | MT0 Nat, (Int _ as l) + | MT0 Int, (Int _ as l) + | MT0 Mutez, (Int _ as l) + | MT0 String, (String _ as l) + | MT0 Bytes, (Bytes _ as l) + | MT0 Chain_id, (Bytes _ as l) + | MT0 Timestamp, ((Int _ | String _) as l) + | MT0 Address, ((Bytes _ | String _) as l) + | MT0 Key, ((Bytes _ | String _) as l) + | MT0 Key_hash, ((Bytes _ | String _) as l) + | MT0 Signature, ((Bytes _ | String _) as l) + | MT0 (Sapling_state _), (Seq [] as l) + | MT0 (Sapling_transaction _), (String "FAKE_SAPLING_TRANSACTION" as l) + | MT0 Bls12_381_g1, (Bytes _ as l) + | MT0 Bls12_381_g2, (Bytes _ as l) + | MT0 Bls12_381_fr, (Bytes _ as l) + | MT0 Chest_key, (Bytes _ as l) + | MT0 Chest, (Bytes _ as l) -> return l + | MT1 (Contract, _), (String _ as l) -> + (* needed for scenarios: "Contract_*" *) return l + | MT2 (Pair _, fst, snd), Pair (x1, x2) -> + return (Pair (x1 (Ok fst), x2 (Ok snd))) + | MT2 (Pair _, _, _), Seq xs -> + let xs = List.map (fun (t, x) -> x (Ok t)) (match_comb t xs) in + return (comb_literal xs).tliteral + | MT2 (Or _, left, _), Left x -> return (Left (x (Ok left))) + | MT2 (Or _, _, right), Right x -> return (Right (x (Ok right))) + | MT1 (Option, t), Some_ x -> return (Some_ (x (Ok t))) + | MT1 (Option, _), None_ -> return None_ + | MT1 ((Set | List), t), Seq xs -> + return (Seq (List.map (fun x -> x (Ok t)) xs)) + | MT2 ((Map | Big_map), _tk, _tv), Seq [] -> return (AnyMap []) + | MT2 ((Map | Big_map), _tk, _tv), Seq (_ :: _) -> + assert false (* eliminated by 'sanitize' *) + | MT2 ((Map | Big_map), tk, tv), AnyMap xs -> + let f (k, v) = (k (Ok tk), v (Ok tv)) in + return (AnyMap (List.map f xs)) + | MT2 (Lambda, t_in, _), Instr i -> + return (Instr (i (Ok (Stack_ok [t_in])))) + | MT2 (Lambda, _t1, _), Seq (_ :: _) -> + assert false (* eliminated by 'sanitize' *) + | MT2 (Lambda, t_in, _), Lambda_rec i -> + return (Lambda_rec (i (Ok (Stack_ok [t_in; t])))) + | ( ( MT0 + ( Unit + | Bool + | Nat + | Int + | Mutez + | String + | Bytes + | Chain_id + | Timestamp + | Address + | Key + | Key_hash + | Signature + | Operation + | Sapling_state _ + | Sapling_transaction _ + | Never + | Bls12_381_g1 + | Bls12_381_g2 + | Bls12_381_fr + | Chest_key + | Chest ) + | MT1 ((Option | List | Set | Contract | Ticket), _) + | MT2 ((Pair _ | Or _ | Lambda | Map | Big_map), _, _) + | MT_var _ ) + , ( Int _ + | Bool _ + | String _ + | Bytes _ + | Unit + | Pair _ + | None_ + | Left _ + | Right _ + | Some_ _ + | Seq _ + | Elt _ + | AnyMap _ + | Instr _ + | Lambda_rec _ ) ) -> + let msg = + let literal = map_literal_f fst fst literal in + let l = MLiteral.to_michelson_string show_instr {literal} in + let t = string_of_mtype ~html:false t in + sprintf "Literal %s does not have type %s." l t + in + error msg + in + match r with + | Ok tliteral -> + let r = + sequence_literal_f + (map_literal_f (fun {stack_out} -> stack_out) (fun {t} -> t) tliteral) + in + let t = + match Result.get_error r with + | Some error -> Error (Printf.sprintf "type error in literal %s" error) + | None -> t + in + {tliteral; t} + | Error msg -> + let err = Error "type error in literal" in + let tliteral = + map_literal_f (fun f -> f err) (fun f -> f err) tliteral' + in + {tliteral; t = Error msg} + +let typecheck_instr_f ~protocol ~tparameter i (stack_in : stack Result.t) : + tinstr = + let i : (stack Result.t -> tinstr, mtype Result.t -> tliteral) instr_f = + map_instr_f snd snd i + in + let on_error_stack stack_in msg = + let err = Error "outer error" in + let tinstr = map_instr_f (fun x -> x err) (fun x -> x err) i in + {tinstr; stack_in; stack_out = Error msg} + in + match (stack_in, i) with + | _, (MIcomment _ as tinstr) -> {tinstr; stack_in; stack_out = stack_in} + | Ok (Stack_ok stack), _ -> + let {rule} = spec_of_instr ~protocol i in + let okify f x = f (Ok x) in + let tinstr, stack_out = rule ~tparameter stack (map_instr_f id okify i) in + {tinstr; stack_in; stack_out} + | Ok Stack_failed, _ -> on_error_stack stack_in "instruction on failed stack" + | Error _, _ -> on_error_stack stack_in "previous error" + +let typecheck_alg ~protocol ~tparameter = + let p_instr = typecheck_instr_f ~protocol ~tparameter in + let p_literal = typecheck_literal_f ~tparameter in + para_alg ~p_instr ~p_literal + +let typecheck_instr ~protocol ~tparameter stack i = + let i = sanitize_instr i in + snd (cata_instr (typecheck_alg ~protocol ~tparameter) i) (Ok stack) + +let typecheck_literal ~protocol ~tparameter t l = + let l = sanitize_literal l in + snd (cata_literal (typecheck_alg ~protocol ~tparameter) l) (Ok t) + +let has_error ~path ~accept_missings = + let has_missing_type t = + if accept_missings then [] else has_missing_type ~path t + in + let f_tinstr ~stack_in:_ ~stack_out instr = + match stack_out with + | Error s -> [s] + | Ok _ -> ( + match instr with + | MIerror s -> [s] + | MI0 (Nil t) + | MI0 (Empty_set t) + | MI0 (None_ t) + | MI1 (Left (_, _, t)) + | MI1 (Right (_, _, t)) + | MI1 (Contract (_, t)) + | MI1 (Unpack t) -> has_missing_type t + | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> + has_missing_type k @ has_missing_type v + | MIpush (t, _) -> has_missing_type t + | MImich {typesIn; typesOut} -> + List.concat_map has_missing_type typesIn + @ List.concat_map has_missing_type typesOut + | MIlambda (t1, t2, _i) as x -> + has_missing_type t1 @ has_missing_type t2 + @ fold_instr_f ( @ ) (curry fst) [] x + | x -> fold_instr_f ( @ ) (curry fst) [] x) + in + let f_tliteral ~t _ = + match t with + | Error msg -> [msg] + | Ok t -> has_missing_type t + in + cata_tinstr {f_tinstr; f_tliteral} + +let name_of_instr_exn ~protocol = function + | ( MI0 + ( Sender + | Source + | Amount + | Balance + | Level + | Now + | Self _ + | Self_address + | Chain_id + | Total_voting_power + | Sapling_empty_state _ + | Unit_ + | None_ _ + | Nil _ + | Empty_set _ + | Empty_map _ + | Empty_bigmap _ ) + | MI1 + ( Car + | Cdr + | Left _ + | Right _ + | Some_ + | Eq + | Abs + | Neg + | Int + | Nat + | Bytes + | IsNat + | Neq + | Le + | Lt + | Ge + | Gt + | Not + | Concat1 + | Size + | Address + | Implicit_account + | Contract _ + | Pack + | Unpack _ + | Hash_key + | Blake2b + | Sha256 + | Sha512 + | Keccak + | Sha3 + | Set_delegate + | Read_ticket + | Join_tickets + | Pairing_check + | Voting_power + | Getn _ + | Cast _ + | Rename _ + | Emit _ ) + | MI1_fail (Failwith | Never) + | MI2 + ( Pair _ + | Add + | Mul + | Sub + | Sub_mutez + | Lsr + | Lsl + | Xor + | Ediv + | And + | Or + | Cons + | Compare + | Concat2 + | Get + | Mem + | Exec + | Apply + | Ticket + | Ticket_deprecated + | Split_ticket + | Updaten _ + | View _ ) + | MIdrop | MIswap + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MImich _ + | MIdropn _ + | MIdup _ + | MIpush _ + | MIunpair _ + | MIpairn _ + | MIfield _ + | MIsetField _ + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved ) as instr -> name_of_instr ~protocol instr + | MIdip _ -> "DIP" + | MIdipn _ -> "DIPN" + | MIloop _ -> "LOOP" + | MIloop_left _ -> "LOOP_LEFT" + | MIiter _ -> "ITER" + | MImap _ -> "MAP" + | MIif_left _ -> "IF_LEFT" + | MIif_none _ -> "IF_NONE" + | MIif_cons _ -> "IF_CONS" + | MIif _ -> "IF" + | MIdig _ -> "DIG" + | MIdug _ -> "DUG" + | MIlambda _ -> "LAMBDA" + | MIlambda_rec _ -> "LAMBDA_REC" + | MIerror _ -> failwith "name_of_instr_exn: MIerror" + | MIcomment _ -> failwith "name_of_instr_exn: MIcomment" + | MIseq _ -> failwith "name_of_instr_exn: MIseq" + | MIcreate_contract _ -> "CREATE_CONTRACT" + | MI2 Sapling_verify_update -> "SAPLING_VERIFY_UPDATE" + +let two_field_annots = function + | Some a1, Some a2 -> ["%" ^ a1; "%" ^ a2] + | Some a1, None -> ["%" ^ a1] + | None, Some a2 -> ["%"; "%" ^ a2] + | None, None -> [] + +let display_view display_instr {name; tparameter; treturn; onchain_code} = + match onchain_code with + | None -> "" + | Some code -> + sprintf "\nview\n %S %s %s\n%s;" name + (string_of_mtype ~protect:() ~html:false + (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:false treturn) + (display_instr code) + +let buffer_f ~protocol ~html ~show_stack ~new_line b = + let new_line = if new_line then "\n" else "" in + let f_tliteral ~t:_ x indent protect = + let out_str x = Buffer.add_string b x in + let spaces n = + if html + then String.concat "" (List.init n (fun _ -> " ")) + else String.make n ' ' + in + let do_indent () = + Buffer.add_string b (spaces (if new_line = "" then 1 else indent)) + in + let line_str x = + do_indent (); + out_str x; + out_str new_line + in + let prot = Misc.buffer_protect b protect "(" ")" in + let elt (k, v) = + Buffer.add_string b "Elt "; + k indent true; + Buffer.add_string b " "; + v indent true + in + let sub1 name x = + prot (fun () -> + Buffer.add_string b name; + Buffer.add_string b " "; + x indent true) + in + match x with + | Int i -> Buffer.add_string b (Big_int.string_of_big_int i) + | Unit -> Buffer.add_string b "Unit" + | String s -> bprintf b "%S" s + | Bool true -> Buffer.add_string b "True" + | Bool false -> Buffer.add_string b "False" + | Pair (l, r) -> + prot (fun () -> + Buffer.add_string b "Pair "; + l indent true; + Buffer.add_string b " "; + r indent true) + | None_ -> Buffer.add_string b "None" + | Left x -> sub1 "Left" x + | Right x -> sub1 "Right" x + | Some_ x -> sub1 "Some" x + | Bytes string_bytes -> + Buffer.add_string b "0x"; + Buffer.add_string b Hex.(show (of_string string_bytes)) + | Seq xs -> + Misc.buffer_protect b true "{" "}" (fun () -> + Misc.buffer_concat b "; " (fun x -> x indent false) xs) + | Elt (k, v) -> elt (k, v) + | AnyMap xs -> + Misc.buffer_protect b true "{" "}" (fun () -> + Misc.buffer_concat b "; " elt xs) + | Instr i -> i ~sub:false (indent + 2) + | Lambda_rec i -> + prot (fun () -> + line_str "Lambda_rec "; + i ~sub:false (indent + 2)) + | Constant hash -> bprintf b "(constant %S)" hash + in + let f_tinstr ~stack_in:_ ~stack_out x ~sub indent = + let spaces n = + if html + then String.concat "" (List.init n (fun _ -> " ")) + else String.make n ' ' + in + let out x = kbprintf (fun _ -> ()) b x in + let out_str x = Buffer.add_string b x in + let do_indent () = + Buffer.add_string b (spaces (if new_line = "" then 1 else indent)) + in + let line x = + do_indent (); + kbprintf (fun _ -> out_str new_line) b x + in + let line_str x = + do_indent (); + out_str x; + out_str new_line + in + let with_stack s = + do_indent (); + let l1 = Buffer.length b in + s (); + let l2 = Buffer.length b in + out ";"; + if show_stack then out_str (spaces (max 0 (10 - (l2 - l1)))) + in + let span className text = + if html then sprintf "%s" className text else text + in + let sub1 name code = + line_str name; + code ~sub:true (indent + 2); + out_str ";" + in + let sub2 name l r = + line_str name; + l ~sub:true (indent + 2); + out_str new_line; + r ~sub:true (indent + 2); + out_str ";" + in + (match x with + | MIseq [] -> + do_indent (); + out_str "{}" + | MIseq l -> + do_indent (); + out_str "{"; + List.iter + (fun i -> + out_str new_line; + i ~sub:false (indent + 2)) + l; + out_str new_line; + do_indent (); + out_str "}"; + if not sub then out_str ";" + | MIdip code -> sub1 "DIP" code + | MIdipn (n, code) -> sub1 (sprintf "DIP %i" n) code + | MIloop code -> sub1 "LOOP" code + | MIloop_left code -> sub1 "LOOP_LEFT" code + | MIiter code -> sub1 "ITER" code + | MImap code -> sub1 "MAP" code + | MIif_left (l, r) -> sub2 "IF_LEFT" l r + | MIif_none (l, r) -> sub2 "IF_NONE" l r + | MIif_cons (l, r) -> sub2 "IF_CONS" l r + | MIif (l, r) -> sub2 "IF" l r + | MIcomment comments -> + let lines = + List.concat (List.map (String.split_on_char '\n') comments) + in + List.iteri + (fun i line -> + if i <> 0 then out_str new_line; + do_indent (); + out_str (span "comment" (sprintf "# %s" line))) + lines + | MIdig n -> with_stack (fun () -> out "DIG %d" n) + | MIdug n -> with_stack (fun () -> out "DUG %d" n) + | MIdropn n -> with_stack (fun () -> out "DROP %d" n) + | MIdup 1 -> with_stack (fun () -> out_str "DUP") + | MIunpair [true; true] -> with_stack (fun () -> out_str "UNPAIR") + | MI0 (Sapling_empty_state {memo}) -> + with_stack (fun () -> out "SAPLING_EMPTY_STATE %d" memo) + | MIdup n -> with_stack (fun () -> out "DUP %d" n) + | MIunpair n -> with_stack (fun () -> out "UNPAIR %s" (unpair_arg n)) + | MIpairn n -> with_stack (fun () -> out "PAIR %d" n) + | MI1 (Getn n) -> with_stack (fun () -> out "GET %d" n) + | MI2 (Updaten n) -> with_stack (fun () -> out "UPDATE %d" n) + | MI2 (View (name, t)) -> + with_stack (fun () -> + out "VIEW %S %s" name (string_of_mtype ~protect:() ~html t)) + | MIerror error -> + do_indent (); + out_str (span "partial-type" (sprintf "MIerror: %s" error)) + | MI0 (Empty_set t) + | MI0 (Nil t) + | MI0 (None_ t) + | MI1 (Contract (None, t)) + | MI1 (Unpack t) + | MI1 (Cast t) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + out_str " "; + buffer_mtype ~html ~protect:() b t) + | MI1 (Rename a) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + match a with + | None -> () + | Some a -> + out_str " @"; + out_str a) + | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + out_str " "; + out_str + (String.concat " " + [ + string_of_mtype ~protect:() ~html k + ; string_of_mtype ~protect:() ~html v + ])) + | MI1 (Left (a1, a2, t) | Right (a1, a2, t)) -> + with_stack (fun () -> + out_str + (String.concat " " + (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2))); + out_str " "; + out_str (string_of_mtype ~protect:() ~html t)) + | MI2 (Pair (a1, a2)) -> + with_stack (fun () -> + out_str + (String.concat " " + (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2)))) + | MI1 (Contract (Some ep, t)) -> + with_stack (fun () -> + out "CONTRACT %%%s %s" ep (string_of_mtype ~protect:() ~html t)) + | MIpush (t, l) -> + with_stack (fun () -> + out "PUSH %s " (string_of_mtype ~protect:() ~html t); + l indent true) + | MI0 (Self (Some entrypoint)) -> + with_stack (fun () -> out "SELF %%%s" entrypoint) + | MIlambda (t1, t2, l) -> + line "LAMBDA"; + line " %s" (string_of_mtype ~protect:() ~html t1); + line " %s" (string_of_mtype ~protect:() ~html t2); + l ~sub:true (indent + 2); + out_str ";" + | MIlambda_rec (t1, t2, l) -> + line "LAMBDA_REC"; + line " %s" (string_of_mtype ~protect:() ~html t1); + line " %s" (string_of_mtype ~protect:() ~html t2); + l ~sub:true (indent + 2); + out_str ";" + | MI1 (Emit (tag, ty)) -> + (do_indent (); + out "EMIT"; + (match tag with + | None -> () + | Some tag -> out " %s" tag); + match ty with + | None -> () + | Some ty -> out " %s" (string_of_mtype ~protect:() ~html ty)); + out_str ";" + | MIcreate_contract {tparameter = t, annot; tstorage; code; views} -> + let view {name; tparameter; treturn; onchain_code} = + match onchain_code with + | None -> () + | Some code -> + line " view"; + line " %S %s %s" name + (string_of_mtype ~protect:() ~html:false + (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:false treturn); + code ~sub:true (indent + 5); + out ";%s" new_line + in + line "CREATE_CONTRACT"; + line " { parameter %s;" (string_of_tparameter ~html (t, annot)); + line " storage %s;" (string_of_mtype ~protect:() ~html tstorage); + line " code"; + code ~sub:true (indent + 5); + out ";%s" new_line; + List.iter view views; + do_indent (); + out " };" + | ( MI0 + ( Self None + | Sender + | Source + | Amount + | Balance + | Level + | Now + | Self_address + | Chain_id + | Total_voting_power + | Unit_ ) + | MI1 + ( Car + | Cdr + | Some_ + | Eq + | Abs + | Neg + | Nat + | Int + | Bytes + | IsNat + | Neq + | Le + | Lt + | Ge + | Gt + | Not + | Concat1 + | Size + | Address + | Implicit_account + | Pack + | Hash_key + | Blake2b + | Sha256 + | Sha512 + | Keccak + | Sha3 + | Set_delegate + | Read_ticket + | Join_tickets + | Pairing_check + | Voting_power ) + | MI1_fail (Failwith | Never) + | MI2 + ( Add + | Mul + | Sub + | Sub_mutez + | Lsr + | Lsl + | Xor + | Ediv + | And + | Or + | Cons + | Compare + | Concat2 + | Get + | Mem + | Exec + | Apply + | Sapling_verify_update + | Ticket + | Ticket_deprecated + | Split_ticket ) + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MIdrop + | MIswap + | MImich _ + | MIfield _ + | MIsetField _ + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved ) as simple -> + with_stack (fun () -> out_str (name_of_instr_exn ~protocol simple))); + let full = + match x with + | MIerror _ -> Some () + | _ when full_types_and_tags -> Some () + | _ -> None + in + if show_stack && not sub + then + match stack_out with + | Ok inst -> + out " %s %s" (span "comment" "#") + (span "stack" (sprintf "%s" (string_of_stack ?full inst))) + | Error msg -> out " # Error: %s" (span "partial-type" msg) + in + {f_tinstr; f_tliteral} + +let _buffer_tliteral ~protocol ~html ~show_stack b indent protect x = + cata_tliteral + (buffer_f ~protocol ~html ~show_stack ~new_line:true b) + x indent protect + +let buffer_tinstr ~protocol ~html ~show_stack ~sub ~new_line b indent x = + cata_tinstr (buffer_f ~protocol ~html ~show_stack ~new_line b) x ~sub indent + +let seq_snoc xs x = + match xs with + | {tinstr = MIseq xs; stack_in} -> + {tinstr = MIseq (xs @ [x]); stack_in; stack_out = x.stack_out} + | xs -> + {tinstr = MIseq [xs; x]; stack_in = xs.stack_in; stack_out = x.stack_out} + +let wrap_in_seq = function + | {tinstr = MIseq _} as i -> i + | i -> {tinstr = MIseq [i]; stack_in = i.stack_in; stack_out = i.stack_out} + +let insert_subsequences = + let f_tinstr ~stack_in ~stack_out = function + | MIseq _ as tinstr -> {tinstr; stack_in; stack_out} + | tinstr -> + {tinstr = map_instr_f wrap_in_seq id tinstr; stack_in; stack_out} + in + cata_tinstr {f_tinstr; f_tliteral = (fun ~t tliteral -> {tliteral; t})} + +let display_tinstr ~protocol ~show_stack ~new_line indent inst = + let inst = insert_subsequences inst in + Misc.with_buffer (fun b -> + buffer_tinstr ~protocol ~html:false ~show_stack ~sub:true ~new_line b + indent inst) + +let render_tinstr ~protocol ~show_stack indent inst = + let inst = insert_subsequences inst in + Misc.with_buffer (fun b -> + buffer_tinstr ~protocol ~html:true ~show_stack ~sub:true ~new_line:true b + indent inst) + +let pretty_literal_f literal wrap ppf = + let open Format in + let wrap x = if wrap then Format.fprintf ppf "(%t)" x else x ppf in + match (literal : _ literal_f) with + | Int i -> fprintf ppf "%s" (Big_int.string_of_big_int i) + | Unit -> fprintf ppf "Unit" + | String s -> fprintf ppf "%S" s + | Bool true -> fprintf ppf "True" + | Bool false -> fprintf ppf "False" + | Pair (l, r) -> wrap (fun ppf -> fprintf ppf "Pair %t %t" (l true) (r true)) + | None_ -> fprintf ppf "None" + | Left x -> wrap (fun ppf -> fprintf ppf "Left %t" (x true)) + | Right x -> wrap (fun ppf -> fprintf ppf "Right %t" (x true)) + | Some_ x -> wrap (fun ppf -> fprintf ppf "Some %t" (x true)) + | Bytes s -> fprintf ppf "0x%s" Hex.(show (of_string s)) + | Seq xs -> + let f i x = + let x = x false in + let s = Format.asprintf "%t" x in + if i = 0 || s = "" then fprintf ppf "%s" s else fprintf ppf "; %s" s + in + fprintf ppf "{"; + List.iteri f xs; + fprintf ppf "}" + | Elt (k, v) -> wrap (fun ppf -> fprintf ppf "Elt %t %t" (k true) (v true)) + | Instr i -> i true ppf + | Lambda_rec i -> wrap (fun ppf -> fprintf ppf "Lambda_rec %t" (i true)) + | AnyMap xs -> + let f i (k, v) = + if i = 0 + then fprintf ppf "Elt %t %t" (k true) (v true) + else fprintf ppf "; Elt %t %t" (k true) (v true) + in + fprintf ppf "{"; + List.iteri f xs; + fprintf ppf "}" + | Constant hash -> wrap (fun ppf -> fprintf ppf "constant %S" hash) + +let pretty_instr_f ~protocol i wrap ppf = + let open Format in + let name ppf = fprintf ppf "%s" (name_of_instr_exn ~protocol i) in + let wrap x = if wrap then Format.fprintf ppf "{ %t }" x else x ppf in + match i with + | MIseq [] -> fprintf ppf "{}" + | MIseq (x :: xs) -> + fprintf ppf "{ %t" (x false); + List.iter (fun x -> fprintf ppf "; %t" (x false)) xs; + fprintf ppf " }" + | MIdipn (n, i) -> wrap (fun ppf -> fprintf ppf "DIP %i %t" n (i true)) + | MIdip i | MIloop i | MIloop_left i | MIiter i | MImap i -> + fprintf ppf "%t %t" name (i true) + | MIif_left (i1, i2) | MIif_none (i1, i2) | MIif_cons (i1, i2) | MIif (i1, i2) + -> wrap (fun ppf -> fprintf ppf "%t %t %t" name (i1 true) (i2 true)) + | MIdup 1 -> wrap (fun ppf -> fprintf ppf "%t" name) + | MIunpair [true; true] -> wrap (fun ppf -> fprintf ppf "%t" name) + | MIunpair n -> wrap (fun ppf -> fprintf ppf "%t %s" name (unpair_arg n)) + | MIpairn n -> wrap (fun ppf -> fprintf ppf "%t %d" name n) + | MIdig n + | MIdug n + | MIdropn n + | MI1 (Getn n) + | MI2 (Updaten n) + | MIdup n + | MI0 (Sapling_empty_state {memo = n}) -> + wrap (fun ppf -> fprintf ppf "%t %d" name n) + | MIcomment _xs -> wrap (fun _ppf -> ()) + | MIerror msg -> wrap (fun ppf -> fprintf ppf "ERROR %s" msg) + | MI1 (Cast t) + | MI0 (Nil t | Empty_set t | None_ t) + | MI1 (Contract (None, t) | Unpack t | Left (_, _, t) | Right (_, _, t)) -> + wrap (fun ppf -> + fprintf ppf "%t %s" name (string_of_mtype ~protect:() ~html:false t)) + | MI1 (Rename a) -> + let a = Option.cata "" (( ^ ) "@") a in + wrap (fun ppf -> fprintf ppf "%t%s" name a) + | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> + wrap (fun ppf -> + fprintf ppf "%t %s %s" name + (string_of_mtype ~protect:() ~html:false k) + (string_of_mtype ~protect:() ~html:false v)) + | MI1 (Contract (Some ep, t)) -> + wrap (fun ppf -> + fprintf ppf "CONTRACT %%%s %s" ep + (string_of_mtype ~protect:() ~html:false t)) + | MI2 (View (name, t)) -> + wrap (fun ppf -> + fprintf ppf "VIEW %S %s" name + (string_of_mtype ~protect:() ~html:false t)) + | MIlambda (t1, t2, c) -> + wrap (fun ppf -> + let t1 = string_of_mtype ~protect:() ~html:false t1 in + let t2 = string_of_mtype ~protect:() ~html:false t2 in + fprintf ppf "LAMBDA %s %s %t" t1 t2 (c true)) + | MIlambda_rec (t1, t2, c) -> + wrap (fun ppf -> + let t1 = string_of_mtype ~protect:() ~html:false t1 in + let t2 = string_of_mtype ~protect:() ~html:false t2 in + fprintf ppf "LAMBDA_REC %s %s %t" t1 t2 (c true)) + | MI1 (Emit (tag, ty)) -> + wrap (fun ppf -> + let tag = + match tag with + | None -> "" + | Some tag -> tag + in + let ty = + match ty with + | None -> "" + | Some ty -> string_of_mtype ~protect:() ~html:false ty + in + fprintf ppf "EMIT%s%s" tag ty) + | MIpush (t, l) -> + wrap (fun ppf -> + let t = string_of_mtype ~protect:() ~html:false t in + let l = l true in + fprintf ppf "PUSH %s %t" t l) + | MIcreate_contract {tparameter = tparameter, annot; tstorage; code; views} -> + let display_instr i = Format.asprintf "%t" (i false) in + let views = + String.concat "\n" + (List.map (fun v -> "; " ^ display_view display_instr v) views) + in + wrap (fun ppf -> + fprintf ppf "CREATE_CONTRACT { parameter %s; storage %s; code %t%s}" + (string_of_tparameter ~html:false (tparameter, annot)) + (string_of_mtype ~protect:() ~html:false tstorage) + (code true) views) + | MI0 + ( Sender + | Source + | Amount + | Balance + | Level + | Now + | Self_address + | Chain_id + | Total_voting_power + | Unit_ + | Self _ ) + | MI1 + ( Car + | Cdr + | Some_ + | Eq + | Abs + | Neg + | Int + | Nat + | Bytes + | IsNat + | Neq + | Le + | Lt + | Ge + | Gt + | Not + | Concat1 + | Size + | Address + | Implicit_account + | Pack + | Hash_key + | Blake2b + | Sha256 + | Sha512 + | Keccak + | Sha3 + | Set_delegate + | Read_ticket + | Join_tickets + | Pairing_check + | Voting_power ) + | MI1_fail (Failwith | Never) + | MI2 + ( Pair _ + | Add + | Mul + | Sub + | Sub_mutez + | Lsr + | Lsl + | Xor + | Ediv + | And + | Or + | Cons + | Compare + | Concat2 + | Get + | Mem + | Exec + | Apply + | Sapling_verify_update + | Ticket + | Ticket_deprecated + | Split_ticket ) + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MIdrop | MIswap | MImich _ | MIfield _ | MIsetField _ + | MIconcat1 | MIconcat2 | MIconcat_unresolved + -> wrap (fun ppf -> fprintf ppf "%t" name) + +let size_instr, _size_literal = + let f_instr = fold_instr_f ( + ) ( + ) 1 in + let f_literal = fold_literal_f ( + ) ( + ) 1 in + cata {f_instr; f_literal} + +let pretty_alg ~protocol = + {f_instr = pretty_instr_f ~protocol; f_literal = pretty_literal_f} + +let _pretty_instr ~protocol = cata_instr (pretty_alg ~protocol) + +let pretty_literal ~protocol = cata_literal (pretty_alg ~protocol) + +let string_of_literal ~protocol m = + Format.asprintf "%t" (pretty_literal ~protocol m true) + +type contract = { + tparameter : mtype * string option + ; tstorage : mtype + ; code : instr + ; views : instr view list +} +[@@deriving show {with_path = false}] + +type instance = { + contract : contract + ; storage : literal option +} +[@@deriving show {with_path = false}] + +type tcontract = { + tparameter : mtype * string option + ; tstorage : mtype + ; code : tinstr + ; views : tinstr view list +} +[@@deriving show {with_path = false}] + +type tinstance = { + contract : tcontract + ; storage : tliteral option +} +[@@deriving show {with_path = false}] + +module Of_micheline = struct + open Micheline + + let rec mtype x = fst (mtype_annotated x) + + and mtype_annotated = function + | Micheline.Primitive {name; annotations; arguments} as p -> + let mt = + match (name, arguments) with + | "pair", [t1; t2] -> + let fst, annot_fst = mtype_annotated t1 in + let snd, annot_snd = mtype_annotated t2 in + mt_pair ?annot_fst ?annot_snd fst snd + | "pair", l -> ( + match List.rev_map mtype_annotated l with + | [] -> assert false + | (last, annot) :: rest -> + fst + (List.fold_left + (fun (snd, annot_snd) (fst, annot_fst) -> + (mt_pair ?annot_fst ?annot_snd fst snd, None)) + (last, annot) rest)) + | "or", [t1; t2] -> + let left, annot_left = mtype_annotated t1 in + let right, annot_right = mtype_annotated t2 in + mt_or ?annot_left ?annot_right left right + | "unit", [] -> mt_unit + | "bool", [] -> mt_bool + | "mutez", [] -> mt_mutez + | "timestamp", [] -> mt_timestamp + | "nat", [] -> mt_nat + | "int", [] -> mt_int + | "string", [] -> mt_string + | "key", [] -> mt_key + | "signature", [] -> mt_signature + | "bytes", [] -> mt_bytes + | "chain_id", [] -> mt_chain_id + | "key_hash", [] -> mt_key_hash + | "contract", [t] -> mt_contract (mtype t) + | "address", [] -> mt_address + | "list", [t] -> mt_list (mtype t) + | "option", [t] -> mt_option (mtype t) + | "set", [t] -> mt_set (mtype t) + | "map", [t1; t2] -> mt_map (mtype t1) (mtype t2) + | "big_map", [t1; t2] -> mt_big_map (mtype t1) (mtype t2) + | "lambda", [t1; t2] -> mt_lambda (mtype t1) (mtype t2) + | "operation", [] -> mt_operation + | "sapling_state", [Int memo] -> mt_sapling_state (int_of_string memo) + | "sapling_transaction", [Int memo] -> + mt_sapling_transaction (int_of_string memo) + | "never", [] -> mt_never + | "ticket", [t] -> mt_ticket (mtype t) + | "bls12_381_g1", [] -> mt_bls12_381_g1 + | "bls12_381_g2", [] -> mt_bls12_381_g2 + | "bls12_381_fr", [] -> mt_bls12_381_fr + | "chest_key", [] -> mt_chest_key + | "chest", [] -> mt_chest + | _ -> mk_mtype (MT_var (sprintf "Parse type error %S" (pretty "" p))) + in + List.fold_left + (fun (mt, fa) a -> + let update = function + | Some _ -> failwith "duplicate annotation" + | None -> Some (String.sub a 1 (String.length a - 1)) + in + match a.[0] with + | ':' -> ({mt with annot_type = update mt.annot_type}, fa) + | '@' -> ({mt with annot_variable = update mt.annot_variable}, fa) + | '%' -> (mt, update fa) + | _ -> failwith "cannot parse annotation") + (mt, None) annotations + | p -> failwith ("Parse type error " ^ pretty "" p) + + let rec literal x : literal = + match (x : Micheline.t) with + | Int i -> MLiteral.int (Bigint.of_string ~msg:"michelson" i) + | Bytes s -> MLiteral.bytes s + | String s -> MLiteral.string s + | Primitive {name; annotations = _; arguments} -> ( + match (name, arguments) with + | "Unit", [] -> MLiteral.unit + | "False", [] -> MLiteral.bool false + | "True", [] -> MLiteral.bool true + | "Pair", l -> ( + match List.rev l with + | [] -> assert false + | a :: l -> + List.fold_left + (fun x y -> MLiteral.pair (literal y) x) + (literal a) l) + | "None", [] -> MLiteral.none + | "Some", [x] -> MLiteral.some (literal x) + | "Left", [x] -> MLiteral.left (literal x) + | "Right", [x] -> MLiteral.right (literal x) + | "Elt", [k; v] -> MLiteral.elt (literal k) (literal v) + | "Lambda_rec", [x] -> MLiteral.lambda_rec (instruction x) + | _ -> MLiteral.instr (instruction x)) + | Sequence xs -> MLiteral.seq (List.map literal xs) + + and instruction x = + let err () = + MIerror (sprintf "Cannot parse instruction %S" (Micheline.show x)) + in + let cmp instr = MIseq [{instr = MI2 Compare}; {instr}] in + let fail = + MIseq + [{instr = MIpush (mt_unit, MLiteral.unit)}; {instr = MI1_fail Failwith}] + in + let if_op instr x y = + MIseq [{instr}; {instr = MIif (instruction x, instruction y)}] + in + let ifcmp_op instr x y = + MIseq + [ + {instr = MI2 Compare} + ; {instr} + ; {instr = MIif (instruction x, instruction y)} + ] + in + let assert_op instr = + MIseq [{instr}; {instr = MIif ({instr = MIseq []}, {instr = fail})}] + in + let assert_cmp_op instr = + MIseq + [ + {instr = MI2 Compare} + ; {instr} + ; {instr = MIif ({instr = MIseq []}, {instr = fail})} + ] + in + let parse_simple_macro = function + | "FAIL" -> fail + | "ASSERT" -> MIif ({instr = MIseq []}, {instr = fail}) + | "CMPEQ" -> cmp (MI1 Eq) + | "CMPNEQ" -> cmp (MI1 Eq) + | "CMPLT" -> cmp (MI1 Lt) + | "CMPGT" -> cmp (MI1 Gt) + | "CMPLE" -> cmp (MI1 Le) + | "CMPGE" -> cmp (MI1 Ge) + | "ASSERTEQ" -> assert_op (MI1 Eq) + | "ASSERTNEQ" -> assert_op (MI1 Eq) + | "ASSERTLT" -> assert_op (MI1 Lt) + | "ASSERTGT" -> assert_op (MI1 Gt) + | "ASSERTLE" -> assert_op (MI1 Le) + | "ASSERTGE" -> assert_op (MI1 Ge) + | "ASSERT_CMPEQ" -> assert_cmp_op (MI1 Eq) + | "ASSERT_CMPNEQ" -> assert_cmp_op (MI1 Eq) + | "ASSERT_CMPLT" -> assert_cmp_op (MI1 Lt) + | "ASSERT_CMPGT" -> assert_cmp_op (MI1 Gt) + | "ASSERT_CMPLE" -> assert_cmp_op (MI1 Le) + | "ASSERT_CMPGE" -> assert_cmp_op (MI1 Ge) + | "ASSERT_SOME" -> MIif_none ({instr = fail}, {instr = MIseq []}) + | "ASSERT_NONE" -> MIif_none ({instr = MIseq []}, {instr = fail}) + | prim + when String.index_opt prim 'D' = Some 0 + && String.index_opt prim 'P' = Some (String.length prim - 1) + && 2 < String.length prim + && Base.String.count prim ~f:(fun c -> c = 'U') + = String.length prim - 2 -> + let n = String.length prim - 3 in + MIseq [{instr = MIdig n}; {instr = MIdup 1}; {instr = MIdug (n + 1)}] + | prim + when String.index_opt prim 'C' = Some 0 + && String.index_opt prim 'R' = Some (String.length prim - 1) -> ( + let l = + Base.String.fold + (String.sub prim 1 (String.length prim - 2)) + ~init:(Some []) + ~f:(fun acc c -> + match (acc, c) with + | Some acc, 'A' -> Some (A :: acc) + | Some acc, 'D' -> Some (D :: acc) + | _ -> None) + in + match l with + | Some l -> MIfield (List.rev l) + | None -> err ()) + | _ -> err () + in + let instr = + match x with + | Sequence [x] -> (instruction x).instr + | Sequence xs -> MIseq (List.map instruction xs) + | Primitive {name; annotations; arguments} -> ( + match (name, arguments) with + | "RENAME", [] -> + let a = + match annotations with + | [] -> None + | [a] -> Base.String.chop_prefix ~prefix:"@" a + | _ -> assert false + in + MI1 (Rename a) + | "UNIT", [] -> MI0 Unit_ + | "EMPTY_MAP", [k; v] -> + MIpush (mt_map (mtype k) (mtype v), MLiteral.mk_map []) + | "EMPTY_SET", [t] -> MIpush (mt_set (mtype t), MLiteral.set []) + | "EMPTY_BIG_MAP", [k; v] -> MI0 (Empty_bigmap (mtype k, mtype v)) + | "DIP", [x] -> MIdip (instruction x) + | "DIP", [Int i; x] -> MIdipn (int_of_string i, instruction x) + | prim, [x] + when String.index_opt prim 'D' = Some 0 + && String.index_opt prim 'P' = Some (String.length prim - 1) + && 2 < String.length prim + && Base.String.count prim ~f:(fun c -> c = 'I') + = String.length prim - 2 -> + MIdipn (String.length prim - 2, instruction x) + | "LOOP", [x] -> MIloop (instruction x) + | "LOOP_LEFT", [x] -> MIloop_left (instruction x) + | "ITER", [x] -> MIiter (instruction x) + | "MAP", [x] -> MImap (instruction x) + | "DROP", [] -> MIdrop + | "DROP", [Int n] -> MIdropn (int_of_string n) + | "DUP", [] -> MIdup 1 + | "DUP", [Int n] -> MIdup (int_of_string n) + | "DIG", [Int i] -> MIdig (int_of_string i) + | "DUG", [Int i] -> MIdug (int_of_string i) + | "FAILWITH", [] -> MI1_fail Failwith + | "IF", [x; y] -> MIif (instruction x, instruction y) + | "IF_LEFT", [x; y] -> MIif_left (instruction x, instruction y) + | "IF_RIGHT", [x; y] -> MIif_left (instruction y, instruction x) + | "IF_SOME", [x; y] -> MIif_none (instruction y, instruction x) + | "IF_NONE", [x; y] -> MIif_none (instruction x, instruction y) + | "IF_CONS", [x; y] -> MIif_cons (instruction x, instruction y) + | "NIL", [t] -> MI0 (Nil (mtype t)) + | "CONS", [] -> MI2 Cons + | "NONE", [t] -> MI0 (None_ (mtype t)) + | "SOME", [] -> MI1 Some_ + | "PAIR", [] -> MI2 (Pair (None, None)) + | "PAIR", [Int n] -> MIpairn (int_of_string n) + | "LEFT", [t] -> MI1 (Left (None, None, mtype t)) + | "RIGHT", [t] -> MI1 (Right (None, None, mtype t)) + | "PUSH", [t; l] -> MIpush (mtype t, literal l) + | "SWAP", [] -> MIswap + | "UNPAIR", [] -> MIunpair [true; true] + | "UNPAIR", [Int n] -> + MIunpair (List.replicate (int_of_string n) true) + | "CAR", [] -> MIfield [A] + | "CDR", [] -> MIfield [D] + | "CONTRACT", [t] -> + let entrypoint = + match annotations with + | [] -> None + | entrypoint :: _ -> + Base.String.chop_prefix ~prefix:"%" entrypoint + in + MI1 (Contract (entrypoint, mtype t)) + | "VIEW", [String name; t] -> MI2 (View (name, mtype t)) + | "CAST", [t] -> + let t = mtype t in + MI1 (Cast t) + | "EXEC", [] -> MI2 Exec + | "APPLY", [] -> MI2 Apply + | "LAMBDA", [t; u; x] -> MIlambda (mtype t, mtype u, instruction x) + | "LAMBDA_REC", [t; u; x] -> + MIlambda_rec (mtype t, mtype u, instruction x) + | "EMIT", _ -> ( + match (annotations, arguments) with + | [], [] -> MI1 (Emit (None, None)) + | [annot], [] -> MI1 (Emit (Some annot, None)) + | [], [t] -> MI1 (Emit (None, Some (mtype t))) + | [annot], [t] -> MI1 (Emit (Some annot, Some (mtype t))) + | _ -> err ()) + | "CREATE_CONTRACT", [x] -> + let tparameter, tstorage, code = + if false then failwith (Micheline.show x); + match x with + | Sequence + [ + Primitive {name = "parameter"; arguments = [tparameter]} + ; Primitive {name = "storage"; arguments = [tstorage]} + ; Primitive {name = "code"; arguments = [code]} + ] -> + ( ( mtype tparameter + , None (* TODO single entrypoint annotation *) ) + , mtype tstorage + , instruction code ) + | _ -> assert false + in + MIcreate_contract + {tparameter; tstorage; code; views = (* TODO *) []} + | "SELF", [] -> + let entrypoint = + match annotations with + | [] -> None + | entrypoint :: _ -> + Base.String.chop_prefix ~prefix:"%" entrypoint + in + MI0 (Self entrypoint) + | "ADDRESS", [] -> MI1 Address + | "SELF_ADDRESS", [] -> MI0 Self_address + | "IMPLICIT_ACCOUNT", [] -> MI1 Implicit_account + | "TRANSFER_TOKENS", [] -> MI3 Transfer_tokens + | "CHECK_SIGNATURE", [] -> MI3 Check_signature + | "SET_DELEGATE", [] -> MI1 Set_delegate + | "SAPLING_EMPTY_STATE", [Int memo] -> + MI0 (Sapling_empty_state {memo = int_of_string memo}) + | "SAPLING_VERIFY_UPDATE", [] -> MI2 Sapling_verify_update + | "NEVER", [] -> MI1_fail Never + | "READ_TICKET", [] -> MI1 Read_ticket + | "TICKET", [] -> MI2 Ticket + | "TICKET_DEPRECATED", [] -> MI2 Ticket_deprecated + | "SPLIT_TICKET", [] -> MI2 Split_ticket + | "JOIN_TICKETS", [] -> MI1 Join_tickets + | "PAIRING_CHECK", [] -> MI1 Pairing_check + | "TOTAL_VOTING_POWER", [] -> MI0 Total_voting_power + | "VOTING_POWER", [] -> MI1 Voting_power + | "EQ", [] -> MI1 Eq + | "NEQ", [] -> MI1 Neq + | "LE", [] -> MI1 Le + | "LT", [] -> MI1 Lt + | "GE", [] -> MI1 Ge + | "GT", [] -> MI1 Gt + | "COMPARE", [] -> MI2 Compare + | "MUL", [] -> MI2 Mul + | "ADD", [] -> MI2 Add + | "SUB", [] -> MI2 Sub + | "EDIV", [] -> MI2 Ediv + | "NOT", [] -> MI1 Not + | "AND", [] -> MI2 And + | "OR", [] -> MI2 Or + | "LSL", [] -> MI2 Lsl + | "LSR", [] -> MI2 Lsr + | "SUB_MUTEZ", [] -> MI2 Sub_mutez + | "XOR", [] -> MI2 Xor + | "CONCAT", [] -> MIconcat1 (* Changed from MIconcat_unresolved *) + | "SLICE", [] -> MI3 Slice + | "SIZE", [] -> MI1 Size + | "GET", [] -> MI2 Get + | "GET", [Int x] -> MI1 (Getn (int_of_string x)) + | "UPDATE", [] -> MI3 Update + | "UPDATE", [Int x] -> MI2 (Updaten (int_of_string x)) + | "GET_AND_UPDATE", [] -> MI3 Get_and_update + | "OPEN_CHEST", [] -> MI3 Open_chest + | "SENDER", [] -> MI0 Sender + | "SOURCE", [] -> MI0 Source + | "AMOUNT", [] -> MI0 Amount + | "BALANCE", [] -> MI0 Balance + | "NOW", [] -> MI0 Now + | "LEVEL", [] -> MI0 Level + | "CHAIN_ID", [] -> MI0 Chain_id + | "MEM", [] -> MI2 Mem + | "HASH_KEY", [] -> MI1 Hash_key + | "BLAKE2B", [] -> MI1 Blake2b + | "SHA256", [] -> MI1 Sha256 + | "SHA512", [] -> MI1 Sha512 + | "KECCAK", [] -> MI1 Keccak + | "SHA3", [] -> MI1 Sha3 + | "ABS", [] -> MI1 Abs + | "NEG", [] -> MI1 Neg + | "INT", [] -> MI1 Int + | "NAT", [] -> MI1 Nat + | "BYTES", [] -> MI1 Bytes + | "ISNAT", [] -> MI1 IsNat + | "PACK", [] -> MI1 Pack + | "UNPACK", [t] -> MI1 (Unpack (mtype t)) + | prim, [] -> parse_simple_macro prim + | "IFEQ", [x; y] -> if_op (MI1 Eq) x y + | "IFNEQ", [x; y] -> if_op (MI1 Eq) x y + | "IFLT", [x; y] -> if_op (MI1 Lt) x y + | "IFGT", [x; y] -> if_op (MI1 Gt) x y + | "IFLE", [x; y] -> if_op (MI1 Le) x y + | "IFGE", [x; y] -> if_op (MI1 Ge) x y + | "IFCMPEQ", [x; y] -> ifcmp_op (MI1 Eq) x y + | "IFCMPNEQ", [x; y] -> ifcmp_op (MI1 Eq) x y + | "IFCMPLT", [x; y] -> ifcmp_op (MI1 Lt) x y + | "IFCMPGT", [x; y] -> ifcmp_op (MI1 Gt) x y + | "IFCMPLE", [x; y] -> ifcmp_op (MI1 Le) x y + | "IFCMPGE", [x; y] -> ifcmp_op (MI1 Ge) x y + (* TODO Macros: ASSERT_SOME, ASSERT_LEFT, ASSERT_RIGHT *) + | _ -> err ()) + | _ -> err () + in + {instr} + + let contract = + let read_element (p, s, c, vs) = function + | Micheline.Primitive {name = "parameter"; arguments} -> ( + match (p, arguments) with + | None, [parameter] -> + let parameter = mtype_annotated parameter in + (Some parameter, s, c, vs) + | None, _ -> failwith "ill-formed 'parameter'" + | Some _, _ -> failwith "'parameter' defined twice") + | Primitive {name = "storage"; arguments} -> ( + match (s, arguments) with + | None, [storage] -> + let storage = mtype storage in + (p, Some storage, c, vs) + | None, _ -> failwith "ill-formed 'storage'" + | Some _, _ -> failwith "'storage' defined twice") + | Primitive {name = "code"; arguments} -> ( + match (c, arguments) with + | None, [code] -> + let code = instruction code in + (p, s, Some code, vs) + | None, _ -> failwith "ill-formed 'code'" + | Some _, _ -> failwith "'code' defined twice") + | Primitive {name = "view"; arguments} -> ( + match arguments with + | [String name; tin; tout; code] -> + let tin = mtype tin in + let tout = mtype tout in + let code = instruction code in + let (view : instr view) = + { + name + ; pure = true + ; doc = "" + ; tparameter = Some tin + ; treturn = tout + ; onchain_code = Some code + ; offchain_code = code + } + in + (p, s, c, view :: vs) + | _ -> failwith "ill-formed 'view'") + | Primitive {name} -> + failwith ("ill-formed contract: unexpected '" ^ name ^ "'") + | _ -> failwith "ill-formed contract: expected primitive" + in + function + | Micheline.Sequence s -> ( + match List.fold_left read_element (None, None, None, []) s with + | None, _, _, _ -> failwith "ill-formed contract: missing 'parameter'" + | _, None, _, _ -> failwith "ill-formed contract: missing 'storage'" + | _, _, None, _ -> failwith "ill-formed contract: missing 'code'" + | Some tparameter, Some tstorage, Some code, views -> + let views = List.rev views in + ({contract = {tparameter; tstorage; code; views}; storage = None} + : instance)) + | _ -> failwith "ill-formed contract: not a sequence" +end + +module To_micheline = struct + open Micheline + + let mtype ?annot_field = + cata_mtype ~annot_field (fun ?annot_type ?annot_variable t ~annot_field -> + let annotations = + let get pref = Option.map (( ^ ) pref) in + List.somes + [get "%" annot_field; get ":" annot_type; get "@" annot_variable] + in + let prim = primitive ~annotations in + match t with + | MT0 t -> + let t, memo = string_of_type0 t in + Option.cata (prim t []) (fun x -> prim t [Int x]) memo + | MT1 (t, t1) -> prim (string_of_type1 t) [t1 ~annot_field:None] + | MT2 (t, t1, t2) -> + let t, a1, a2 = string_of_type2 t in + prim t [t1 ~annot_field:a1; t2 ~annot_field:a2] + | MT_var msg -> + primitive "ERROR" + [Format.kasprintf string "Cannot compile missing type: %s" msg]) + + let dip_seq i = primitive "DIP" [sequence i] + + let rec c_ad_r s = + (* + See http://tezos.gitlab.io/mainnet/whitedoc/michelson.html#syntactic-conveniences + > CA(\rest=[AD]+)R / S => CAR ; C(\rest)R / S + > CD(\rest=[AD]+)R / S => CDR ; C(\rest)R / S + *) + match s.[0] with + | 'A' -> primitive "CAR" [] :: c_ad_r (Base.String.drop_prefix s 1) + | 'D' -> primitive "CDR" [] :: c_ad_r (Base.String.drop_prefix s 1) + | exception _ -> [] + | other -> + Format.kasprintf failwith "c_ad_r macro: wrong char: '%c' (of %S)" other + s + + let rec set_c_ad_r s = + (* + See http://tezos.gitlab.io/mainnet/whitedoc/michelson.html#syntactic-conveniences + > SET_CA(\rest=[AD]+)R / S => + { DUP ; DIP { CAR ; SET_C(\rest)R } ; CDR ; SWAP ; PAIR } / S + > SET_CD(\rest=[AD]+)R / S => + { DUP ; DIP { CDR ; SET_C(\rest)R } ; CAR ; PAIR } / S + Then, + > SET_CAR => CDR ; SWAP ; PAIR + > SET_CDR => CAR ; PAIR + *) + match s.[0] with + | 'A' when String.length s > 1 -> + [ + primitive "DUP" [] + ; dip_seq + (primitive "CAR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) + ; primitive "CDR" [] + ; primitive "SWAP" [] + ; primitive "PAIR" [] + ] + | 'A' -> [primitive "CDR" []; primitive "SWAP" []; primitive "PAIR" []] + | 'D' when String.length s > 1 -> + [ + primitive "DUP" [] + ; dip_seq + (primitive "CDR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) + ; primitive "CAR" [] + ; primitive "PAIR" [] + ] + | 'D' -> [primitive "CAR" []; primitive "PAIR" []] + | exception _ -> + Format.kasprintf failwith "set_c_r_macro: called with no chars: S" s + | other -> + Format.kasprintf failwith "set_c_r_macro: wrong char: '%c' (of %S)" + other s + + let rec literal ~protocol {literal = l} = + let literal = literal ~protocol in + let instruction = instruction ~protocol in + match l with + | Int bi -> int (Big_int.string_of_big_int bi) + | Bool false -> primitive "False" [] + | Bool true -> primitive "True" [] + | String s -> string s + | Unit -> primitive "Unit" [] + | Bytes b -> bytes b + | Pair (left, right) -> primitive "Pair" [literal left; literal right] + | None_ -> primitive "None" [] + | Some_ l -> primitive "Some" [literal l] + | Left e -> primitive "Left" [literal e] + | Right e -> primitive "Right" [literal e] + | Seq xs -> xs |> List.map literal |> sequence + | Elt (k, v) -> primitive "Elt" [literal k; literal v] + | Instr x -> sequence (instruction x) + | Lambda_rec x -> primitive "Lambda_rec" (instruction x) + | AnyMap xs -> + let xs = List.map (fun (k, v) -> {literal = Elt (k, v)}) xs in + literal {literal = Seq xs} + | Constant hash -> primitive "constant" [string hash] + + and instruction ~protocol (the_instruction : instr) = + let literal = literal ~protocol in + let instruction = instruction ~protocol in + let prim0 ?annotations n = [primitive ?annotations n []] in + let primn ?annotations n l = [primitive ?annotations n l] in + let rec_instruction instr = Micheline.sequence (instruction instr) in + match the_instruction.instr with + | MIerror s -> primn "ERROR" [string s] + | MIcomment _comment -> + [] + (* + [ primitive "PUSH" [primitive "string" []; string comment] + ; primitive "DROP" [] ] *) + | MIdip instr -> primn "DIP" [rec_instruction instr] + | MIdipn (n, instr) -> + primn "DIP" [int (string_of_int n); rec_instruction instr] + | MIdig n -> primn "DIG" [int (string_of_int n)] + | MIdug n -> primn "DUG" [int (string_of_int n)] + | MIdup 1 -> primn "DUP" [] + | MIdup n -> primn "DUP" [int (string_of_int n)] + | MIunpair [true; true] -> primn "UNPAIR" [] + | MIunpair n -> primn "UNPAIR" [int (unpair_arg n)] + | MIpairn n -> primn "PAIR" [int (string_of_int n)] + | MI1 (Getn n) -> primn "GET" [int (string_of_int n)] + | MI2 (Updaten n) -> primn "UPDATE" [int (string_of_int n)] + | MIdropn n -> primn "DROP" [int (string_of_int n)] + | MIloop instr -> primn "LOOP" [rec_instruction instr] + | MIloop_left instr -> primn "LOOP_LEFT" [rec_instruction instr] + | MIiter instr -> primn "ITER" [rec_instruction instr] + | MImap instr -> primn "MAP" [rec_instruction instr] + | MIseq ils -> List.concat_map instruction ils + | MIif (t, e) -> primn "IF" [rec_instruction t; rec_instruction e] + | MIif_left (t, e) -> primn "IF_LEFT" [rec_instruction t; rec_instruction e] + | MIif_none (t, e) -> primn "IF_NONE" [rec_instruction t; rec_instruction e] + | MIif_cons (t, e) -> primn "IF_CONS" [rec_instruction t; rec_instruction e] + | MIpush (mt, lit) -> primn "PUSH" [mtype mt; literal lit] + | MI0 (Self (Some entrypoint)) -> + primn ~annotations:["%" ^ entrypoint] "SELF" [] + | MI2 (Pair (a1, a2)) -> + primn ~annotations:(two_field_annots (a1, a2)) "PAIR" [] + | MI1 (Right (a1, a2, mty)) -> + primn ~annotations:(two_field_annots (a1, a2)) "RIGHT" [mtype mty] + | MI1 (Left (a1, a2, mty)) -> + primn ~annotations:(two_field_annots (a1, a2)) "LEFT" [mtype mty] + | MI0 (None_ mty) -> primn "NONE" [mtype mty] + | MI0 (Nil mty) -> primn "NIL" [mtype mty] + | MI0 (Empty_set mty) -> primn "EMPTY_SET" [mtype mty] + | MI0 (Empty_map (k, v)) -> primn "EMPTY_MAP" [mtype k; mtype v] + | MI0 (Empty_bigmap (k, v)) -> primn "EMPTY_BIG_MAP" [mtype k; mtype v] + | MI1 (Contract (None, mty)) -> primn "CONTRACT" [mtype mty] + | MI1 (Contract (Some entrypoint, mty)) -> + primn ~annotations:["%" ^ entrypoint] "CONTRACT" [mtype mty] + | MI2 (View (name, mty)) -> primn "VIEW" [string name; mtype mty] + | MI1 (Cast t) -> primn "CAST" [mtype t] + | MI1 (Rename None) -> primn "RENAME" [] + | MI1 (Rename (Some a)) -> primn "RENAME" ~annotations:["@" ^ a] [] + | MIlambda (t1, t2, b) -> + primn "LAMBDA" [mtype t1; mtype t2; rec_instruction b] + | MIlambda_rec (t1, t2, b) -> + primn "LAMBDA_REC" [mtype t1; mtype t2; rec_instruction b] + | MI1 (Emit (tag, ty)) -> + let annotations = + match tag with + | None -> [] + | Some tag -> [tag] + in + let ty = + match ty with + | None -> [] + | Some ty -> [mtype ty] + in + primn ~annotations "EMIT" ty + | MI1 (Unpack mty) -> primn "UNPACK" [mtype mty] + | MIfield op -> c_ad_r (string_of_ad_path op) + | MIsetField op -> set_c_ad_r (string_of_ad_path op) + | MIcreate_contract + {tparameter = tparameter, annot_field; tstorage; code; views} -> + primn "CREATE_CONTRACT" + [ + sequence + (primn "parameter" [mtype ?annot_field tparameter] + @ primn "storage" [mtype tstorage] + @ primn "code" [rec_instruction code] + @ List.concat_map (view ~protocol) views) + ] + | MI0 (Sapling_empty_state {memo}) -> + primn "SAPLING_EMPTY_STATE" [int (string_of_int memo)] + | ( MI0 + ( Sender + | Source + | Amount + | Balance + | Level + | Now + | Self _ + | Self_address + | Chain_id + | Total_voting_power + | Unit_ ) + | MI1 + ( Car + | Cdr + | Some_ + | Eq + | Abs + | Neg + | Int + | Nat + | Bytes + | IsNat + | Neq + | Le + | Lt + | Ge + | Gt + | Not + | Concat1 + | Size + | Address + | Implicit_account + | Pack + | Hash_key + | Blake2b + | Sha256 + | Sha512 + | Keccak + | Sha3 + | Set_delegate + | Read_ticket + | Join_tickets + | Pairing_check + | Voting_power ) + | MI1_fail (Failwith | Never) + | MI2 + ( Add + | Mul + | Sub + | Sub_mutez + | Lsr + | Lsl + | Xor + | Ediv + | And + | Or + | Cons + | Compare + | Concat2 + | Get + | Mem + | Exec + | Apply + | Sapling_verify_update + | Ticket + | Ticket_deprecated + | Split_ticket ) + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MIdrop | MIswap | MImich _ | MIconcat1 | MIconcat2 | MIconcat_unresolved ) as simple -> ( + try prim0 (name_of_instr_exn ~protocol simple) + with _ -> [sequence [primitive "ERROR-NOT-SIMPLE" []]]) + + and view ~protocol {name; tparameter; treturn; onchain_code} = + let open Micheline in + match onchain_code with + | None -> [] + | Some code -> + [ + primitive "view" + [ + literal ~protocol {literal = String name} + ; mtype (Option.default mt_unit tparameter) + ; mtype treturn + ; sequence (instruction ~protocol code) + ] + ] +end + +let count_bigmaps = + let f_tinstr ~stack_in:_ ~stack_out:_ _instr = 0 in + let f_tliteral ~t literal = + let i = + match t with + | Ok {mt = MT2 (Big_map, _, _)} -> 1 + | _ -> 0 + in + fold_literal_f ( + ) ( + ) i literal + in + cata_tliteral {f_tinstr; f_tliteral} + +let unexpected_final_stack_error = "Unexpected final stack" + +let erase_types_contract {tparameter; tstorage; code; views} = + let code = erase_types_instr code in + let views = List.map (map_view erase_types_instr) views in + ({tparameter; tstorage; code; views} : contract) + +let erase_types_instance ({contract; storage} : tinstance) : instance = + let contract = erase_types_contract contract in + let storage = Option.map erase_types_literal storage in + {contract; storage} + +let string_of_tliteral ~protocol x = + string_of_literal ~protocol (erase_types_literal x) + +let typecheck_contract ~protocol + ({tparameter; tstorage; code; views} : contract) = + let code = + typecheck_instr ~protocol ~tparameter + (initial_stack ~tparameter:(fst tparameter) ~tstorage) + code + in + let typecheck_view ({tparameter; onchain_code; offchain_code} as v) = + let check offchain code = + let tparameter, stack = + match tparameter with + | None -> + let stack = + if offchain + then Stack_ok [{tstorage with annot_variable = Some "storage"}] + else initial_stack ~tparameter:mt_unit ~tstorage + in + (mt_unit, stack) + | Some tparameter -> (tparameter, initial_stack ~tparameter ~tstorage) + in + typecheck_instr ~protocol ~tparameter:(tparameter, None) stack code + in + { + v with + onchain_code = Option.map (check false) onchain_code + ; offchain_code = (check true) offchain_code + } + in + let views = List.map typecheck_view views in + let code = + match code.stack_out with + | Ok (Stack_ok [{mt = MT2 (Pair _, fst, snd)}]) + when unifiable_types fst (mt_list mt_operation) + && unifiable_types snd tstorage -> code + | Ok Stack_failed -> code + | Ok _ -> + let msg = unexpected_final_stack_error in + let err = + { + tinstr = MIerror msg + ; stack_in = code.stack_in + ; stack_out = code.stack_out + } + in + seq_snoc code err + | Error _ -> code + in + {tparameter; tstorage; code; views} + +let typecheck_instance ~protocol ({contract; storage} : instance) : tinstance = + let ({tparameter; tstorage} as contract) = + typecheck_contract ~protocol contract + in + let storage = + Option.map (typecheck_literal ~protocol ~tparameter tstorage) storage + in + {contract; storage} + +let has_error_tinstance ~accept_missings + {contract = {tparameter; tstorage; code; views}} = + let has_missing_type ~path t = + if accept_missings then [] else has_missing_type ~path t + in + let errors = + let has_error_view {name; tparameter; treturn; onchain_code; offchain_code} + = + Option.cata [] (has_error ~path:name ~accept_missings) onchain_code + @ has_error ~path:name ~accept_missings offchain_code + @ Option.cata [] (has_missing_type ~path:name) tparameter + @ has_missing_type ~path:name treturn + in + let e = + has_error ~path:"code" ~accept_missings code + @ List.concat_map has_error_view views + in + e + @ has_missing_type ~path:"storage" tstorage + @ has_missing_type ~path:"parameters" (fst tparameter) + in + let rec clean acc = function + | e1 :: e2 :: rest when e1 = e2 -> clean acc (e1 :: rest) + | e :: rest -> clean (e :: acc) rest + | [] -> List.rev acc + in + clean [] errors + +let to_micheline_tinstance ~protocol + {contract = {tstorage; tparameter = tparameter, annot_field; code; views}} = + let open Micheline in + let erase_types_from_instr code = + match To_micheline.instruction ~protocol (erase_types_instr code) with + | [Sequence _] as l -> l + | l -> [sequence l] + in + sequence + ([ + primitive "storage" [To_micheline.mtype tstorage] + ; primitive "parameter" [To_micheline.mtype ?annot_field tparameter] + ; primitive "code" (erase_types_from_instr code) + ] + @ List.concat_map + (To_micheline.view ~protocol) + (List.map (map_view erase_types_instr) views)) + +let display_tinstance ~protocol {contract = {tstorage; tparameter; code; views}} + = + let display_instr = display_tinstr ~show_stack:true ~new_line:true 2 in + sprintf "parameter %s;\nstorage %s;\ncode\n%s;%s" + (string_of_tparameter ~html:false tparameter) + (string_of_mtype ~protect:() ~html:false tstorage) + (display_instr ~protocol code) + (String.concat "" (List.map (display_view (display_instr ~protocol)) views)) + +let render_tinstance ~protocol {contract = {tstorage; tparameter; code; views}} + = + sprintf + "parameter %s;
storage   %s;
code
%s;
%s" + (string_of_tparameter ~html:true tparameter) + (string_of_mtype ~protect:() ~html:true tstorage) + (render_tinstr ~protocol ~show_stack:true 2 code) + (List.fold_left + (fun acc {name; tparameter; treturn; onchain_code} -> + match onchain_code with + | None -> acc + | Some code -> + sprintf + "%s
view
\"%s\" %s %s
%s;
" + acc name + (string_of_mtype ~protect:() ~html:true + (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:true treturn) + (render_tinstr ~protocol ~show_stack:true 2 code)) + "" views) + +let render_tinstance_no_types ~protocol + {contract = {tstorage; tparameter; code; views}} = + sprintf + "parameter %s;
storage   %s;
code
%s;
%s" + (string_of_tparameter ~html:true tparameter) + (string_of_mtype ~protect:() ~html:true tstorage) + (render_tinstr ~protocol ~show_stack:false 2 code) + (List.fold_left + (fun acc {name; tparameter; treturn; onchain_code} -> + match onchain_code with + | None -> acc + | Some code -> + sprintf + "%s
view
\"%s\" %s %s
%s;
" + acc name + (string_of_mtype ~protect:() ~html:true + (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:true treturn) + (render_tinstr ~protocol ~show_stack:false 2 code)) + "" views) + +let profile_of_arity (m, n) = (m, Some (n - m)) + +let arity_of_profile = function + | m, None -> (m, None) + | m, Some d -> (m, Some (m + d)) + +let profile ~protocol = + let open Result in + let ( =?= ) x y = + match x with + | Some x when x <> y -> error "profile: unequal p" + | _ -> return () + in + let if_some d x = Option.map (fun _ -> x) d in + let same x y = + match (x, y) with + | Some x, Some y -> + if x = y then return (Some x) else error "profile: unequal d" + | None, Some y -> return (Some y) + | Some x, None -> return (Some x) + | None, None -> return None + in + let pred = Option.map (fun x -> x - 1) in + let succ = Option.map (fun x -> x + 1) in + let f_instr i = + let* i = sequence_instr_f i in + match i with + | MI1_fail _ -> return (1, None) + | MIdip (p, d) -> return (p + 1, d) + | MIdipn (i, (p, d)) -> return (p + i, d) + | MIloop (p, d) -> + let* () = d =?= 1 in + return (p + 1, if_some d (-1)) + | MIloop_left (p, d) -> + let* () = d =?= 1 in + return (max 1 p, if_some d 0) + | MIiter (p, d) -> + let* () = d =?= -1 in + return (p, Some (-1)) + | MImap (p, d) -> + let* () = d =?= 0 in + return (p, if_some d 0) + | MIdig n | MIdug n -> return (n + 1, Some 0) + | MIif ((p1, d1), (p2, d2)) -> + let* d = same d1 d2 in + return (max p1 p2 + 1, pred d) + | MIif_none ((p1, d1), (p2, d2)) -> + let* d = same (pred d1) d2 in + return (max (p1 + 1) p2, d) + | MIif_left ((p1, d1), (p2, d2)) -> + let* d = same d1 d2 in + return (max p1 p2, d) + | MIif_cons ((p1, d1), (p2, d2)) -> + let* d = same (succ d1) (pred d2) in + return (max (p1 + 1) (p2 - 1), d) + | MIseq xs -> + let f = function + | _, Error e -> Error e + | (p1, None), _ -> return (p1, None) + (* TODO Fix the compiler/rewriter such that they never emit + instructions after FAILWITH and assert false here. *) + | (p1, Some d1), Ok (p2, Some d2) -> + return (max p1 (p2 - d1), Some (d1 + d2)) + | (p1, Some d1), Ok (p2, None) -> return (max p1 (p2 - d1), None) + in + List.fold_right (curry f) xs (return (0, Some 0)) + | MIcomment _ -> return (0, Some 0) + | MIlambda _ -> return (0, Some 1) + | MIlambda_rec _ -> return (0, Some 1) + | MIconcat_unresolved -> failwith "profile: CONCAT arity undetermined" + | MIerror _ -> return (0, Some 0) + | i -> ( + match spec_of_instr ~protocol i with + | {arities = Some a} -> return (profile_of_arity a) + | _ -> assert false) + in + cata_instr {f_instr; f_literal = (fun _ -> return ())} + +let has_profile ~protocol pr instr = Ok pr = profile ~protocol {instr} + +let has_arity ~protocol a instr = + has_profile ~protocol (profile_of_arity a) instr + +let arity ~protocol instr = + Result.map arity_of_profile (profile ~protocol instr) + +let rec mtype_examples t = + match t.mt with + | MT0 Unit -> [MLiteral.unit] + | MT0 Bool -> [MLiteral.bool false; MLiteral.bool true] + | MT0 Nat -> + [ + MLiteral.small_int 0 + ; MLiteral.small_int 2 + ; MLiteral.small_int 4 + ; MLiteral.small_int 8 + ] + | MT0 Int -> + [ + MLiteral.small_int (-2) + ; MLiteral.small_int 10 + ; MLiteral.small_int 5 + ; MLiteral.small_int 3 + ] + | MT0 Mutez -> + [ + MLiteral.small_int 0 + ; MLiteral.small_int 1000 + ; MLiteral.small_int 2000000 + ; MLiteral.small_int 3000000 + ] + | MT0 String -> + [ + MLiteral.string "" + ; MLiteral.string "foo" + ; MLiteral.string "bar" + ; MLiteral.string "SmartPy" + ] + | MT0 Chain_id + | MT0 Bytes + | MT0 Bls12_381_g1 + | MT0 Bls12_381_g2 + | MT0 Bls12_381_fr + | MT0 Chest_key + | MT0 Chest -> + [ + MLiteral.bytes "" + ; MLiteral.bytes (Hex.to_string (`Hex "00")) + ; MLiteral.bytes (Hex.to_string (`Hex "010203")) + ; MLiteral.bytes (Hex.to_string (`Hex "0FFF")) + ] + | MT0 Timestamp -> + [ + MLiteral.small_int 0 + ; MLiteral.small_int 1000 + ; MLiteral.small_int 2000000 + ; MLiteral.small_int 3000000 + ] + | MT0 Address -> + [ + MLiteral.string "tz1..." + ; MLiteral.string "tz2..." + ; MLiteral.string "tz3..." + ; MLiteral.string "KT1..." + ] + | MT0 Key_hash -> + [ + MLiteral.string "tz1..." + ; MLiteral.string "tz2..." + ; MLiteral.string "tz3..." + ] + | MT0 Signature -> [MLiteral.string "edsigt..."; MLiteral.string "edsigu..."] + | MT0 Key -> + [ + MLiteral.string "edpkuvNy6TuQ2z8o9wnoaTtTXkzQk7nhegCHfxBc4ecsd4qG71KYNG" + ; MLiteral.string "edpkvThfdv8Efh1MuqSTUk5EnUFCTjqN6kXDCNXpQ8udN3cKRhNDr2" + ] + | MT1 (Option, t) -> + List.map MLiteral.some (mtype_examples t) @ [MLiteral.none] + | MT1 (List, t) -> [MLiteral.seq (mtype_examples t); MLiteral.seq []] + | MT1 (Set, t) -> [MLiteral.seq (mtype_examples t)] + | MT1 (Contract, _t) -> + [ + MLiteral.string "KT1a..." + ; MLiteral.string "KT1b..." + ; MLiteral.string "KT1c..." + ; MLiteral.string "KT1d..." + ] + | MT2 (Pair _, fst, snd) -> ( + let l1 = mtype_examples fst in + let l2 = mtype_examples snd in + match (l1, l2) with + | a1 :: a2 :: _, b1 :: b2 :: _ -> + [ + MLiteral.pair a1 b1 + ; MLiteral.pair a2 b2 + ; MLiteral.pair a1 b2 + ; MLiteral.pair a2 b1 + ] + | _ -> + List.fold_left + (fun acc b -> + List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) + [] l2) + | MT2 (Or _, left, right) -> ( + let l1 = mtype_examples left in + let l2 = mtype_examples right in + match (l1, l2) with + | a1 :: a2 :: _, b1 :: b2 :: _ -> + [ + MLiteral.left a1 + ; MLiteral.left a2 + ; MLiteral.right b1 + ; MLiteral.right b2 + ] + | _ -> + List.fold_left + (fun acc b -> + List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) + [] l2) + | MT2 (Lambda, _, _) -> [MLiteral.seq []] + | MT2 ((Map | Big_map), k, v) -> + let l1 = mtype_examples k in + let l2 = mtype_examples v in + let rec map2 f acc l1 l2 = + match (l1, l2) with + | a1 :: l1, a2 :: l2 -> map2 f (f a1 a2 :: acc) l1 l2 + | _ -> List.rev acc + in + let l = map2 MLiteral.elt [] l1 l2 in + [MLiteral.seq l] + | MT_var s -> [MLiteral.string (sprintf "no value for %S" s)] + | MT0 Operation -> [MLiteral.string "operation"] + | MT0 (Sapling_state _) -> [MLiteral.seq []] + | MT0 Never -> [MLiteral.string "no value in type never"] + | MT0 (Sapling_transaction _) -> [MLiteral.string "sapling_transaction"] + | MT1 (Ticket, _) -> [MLiteral.string "no example for tickets"] + +let on_instrs f = + let f_instr instr = f {instr} in + let f_literal literal = {literal} in + cata_literal {f_instr; f_literal} + +let display_instr ~protocol t1 instr = + let tinstr = + typecheck_instr ~tparameter:(mt_unit, None) (Stack_ok [t1]) instr + in + display_tinstr ~protocol ~show_stack:false ~new_line:false 0 + (tinstr ~protocol) diff --git a/lltz.opam b/lltz.opam index c30c100..8b8aa5f 100644 --- a/lltz.opam +++ b/lltz.opam @@ -9,7 +9,7 @@ homepage: "https://github.com/trilitech/lltz" bug-reports: "https://github.com/trilitech/lltz/issues" depends: [ "ocaml" {= "4.14.2"} - "dune" {>= "3.15"} + "dune" {>= "3.7"} "core" "ppx_jane" "tezos-micheline" From 43ef79c378d7616dca4fe8350e588903637d25bc Mon Sep 17 00:00:00 2001 From: Alan Marko Date: Mon, 7 Oct 2024 15:02:31 +0100 Subject: [PATCH 2/2] feat(lltz_codegen): formatting --- README.md | 24 +- lib/lltz_codegen/config.ml | 3 + lib/lltz_codegen/ident.ml | 4 +- lib/lltz_codegen/instruction.ml | 257 +- lib/lltz_codegen/lltz_codegen.ml | 327 +- lib/lltz_codegen/slot.ml | 1 + lib/lltz_codegen/stack.ml | 23 +- lib/lltz_codegen/type.ml | 22 +- lib/lltz_ir/dsl.ml | 1379 ++++-- lib/lltz_ir/expr.ml | 329 +- lib/lltz_ir/free_vars.ml | 186 +- lib/lltz_ir/name.ml | 3 +- lib/lltz_ir/row.ml | 2 + lib/lltz_michelson/lltz_michelson.ml | 123 +- lib/michelson/ast.ml | 77 +- .../optimisations/oasis_core/michelson.ml | 3767 ++++++++--------- 16 files changed, 3674 insertions(+), 2853 deletions(-) diff --git a/README.md b/README.md index ab9693c..5dbd0ec 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,21 @@ # LLTZ request for comments -This is a draft implementation of the new shared backend for all Tezos languages. -This is a very early stage draft, no hard decisions have been made, this is a starting point to iterate on so feel free to suggest any changes. + +This is a draft implementation of the new shared backend for all Tezos +languages. This is a very early stage draft, no hard decisions have been made, +this is a starting point to iterate on so feel free to suggest any changes. ## Contributing -* Raise issues with any thoughts or suggested changes. -* Feel free to raise draft PR's and comment on other PR's. If there is sufficient agreement convert it out of draft mode. -* The aim is to create an initial implementation with as much concensus as possible, with the understanding that whatever we come up with will evolve during the implementation. + +- Raise issues with any thoughts or suggested changes. +- Feel free to raise draft PR's and comment on other PR's. If there is + sufficient agreement convert it out of draft mode. +- The aim is to create an initial implementation with as much concensus as + possible, with the understanding that whatever we come up with will evolve + during the implementation. ## Next Steps -* Decide how we will share the code between languages. (Git submodules opam packages etc.) -* Create passes from Michel and Mini-c to LLTZ IR -* Compile LLTZ IR to Michelson. + +- Decide how we will share the code between languages. (Git submodules opam + packages etc.) +- Create passes from Michel and Mini-c to LLTZ IR +- Compile LLTZ IR to Michelson. diff --git a/lib/lltz_codegen/config.ml b/lib/lltz_codegen/config.ml index 569dc2e..9b5c53d 100644 --- a/lib/lltz_codegen/config.ml +++ b/lib/lltz_codegen/config.ml @@ -10,11 +10,13 @@ module ExtStack = struct match t with | Ok stack -> Ok (f stack) | Exceptional -> Exceptional + ;; let merge t1 t2 = match t1, t2 with | Ok stack1, Ok stack2 -> Ok (Stack.merge stack1 stack2) | Exceptional, stack | stack, Exceptional -> stack + ;; end type t = @@ -31,3 +33,4 @@ let merge t1 t2 ~f = { stack = ExtStack.merge t1.stack t2.stack ; instructions = f t1.instructions t2.instructions } +;; diff --git a/lib/lltz_codegen/ident.ml b/lib/lltz_codegen/ident.ml index 2850cf2..bcaa2ac 100644 --- a/lib/lltz_codegen/ident.ml +++ b/lib/lltz_codegen/ident.ml @@ -1,9 +1,9 @@ open Core - include String let create = let next = ref 0 in fun ?(prefix = "_") () -> Int.incr next; - prefix ^ Int.to_string !next \ No newline at end of file + prefix ^ Int.to_string !next +;; diff --git a/lib/lltz_codegen/instruction.ml b/lib/lltz_codegen/instruction.ml index 218cc46..c595c55 100644 --- a/lib/lltz_codegen/instruction.ml +++ b/lib/lltz_codegen/instruction.ml @@ -17,16 +17,17 @@ open Core let noop stack = Config.ok stack [] let seq (ts : t list) : t = - fun stack -> + fun stack -> List.fold_left ts ~init:(noop stack) ~f:(fun ({ instructions = instrs1; stack } as config : Config.t) t -> - match stack with - | Ok stack -> - let { Config.stack; instructions = instrs2 } = t stack in - Config.{ stack; instructions = instrs1 @ instrs2 } - | Exceptional -> config) + match stack with + | Ok stack -> + let { Config.stack; instructions = instrs2 } = t stack in + Config.{ stack; instructions = instrs1 @ instrs2 } + | Exceptional -> config) +;; let rev_prefix n l = let rec aux n acc l = @@ -38,6 +39,7 @@ let rev_prefix n l = | [] -> acc, []) in aux n [] l +;; (* https://tezos.gitlab.io/michelson-reference/#instr-DIG *) let dig n stack = @@ -54,6 +56,7 @@ let dig n stack = | 0 -> [] | 1 -> [ I.swap ] | n -> [ I.dig_n n ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-DUG *) let dug n stack = @@ -70,10 +73,11 @@ let dug n stack = | 0 -> [] | 1 -> [ I.swap ] | n -> [ I.dug_n n ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-DIP *) let dip n (t : t) : t = - fun stack -> + fun stack -> match n with | 0 -> t stack (* noop *) | n -> @@ -90,6 +94,7 @@ let dip n (t : t) : t = | n -> I.dip_n n instructions) ] } +;; (* https://tezos.gitlab.io/michelson-reference/#instr-DUP, stack is 0-indexed *) let dup n stack = @@ -101,6 +106,7 @@ let dup n stack = raise_s [%message "Instruction.dup: invalid stack" (stack : SlotStack.t) (n : int)] in Config.ok stack [ I.dup_n (n + 1) ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-SWAP *) let swap stack = @@ -110,20 +116,25 @@ let swap stack = | _ -> raise_s [%message "Instruction.swap: invalid stack" (stack : SlotStack.t)] in Config.ok stack [ I.swap ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-DROP *) let drop n stack = (* drop's n elements *) - if List.length stack < n then + if List.length stack < n + then raise_s [%message "Instruction.drop: invalid stack" (stack : SlotStack.t) (n : int)] - else + else ( let dropped_stack = List.drop stack n in - let instructions = match n with + let instructions = + match n with | 0 -> [] (* noop *) | 1 -> [ I.drop ] (* drop just one element *) - | _ -> [ I.drop_n n ] (* drop n elements *) + | _ -> [ I.drop_n n ] + (* drop n elements *) in - Config.ok dropped_stack instructions + Config.ok dropped_stack instructions) +;; let remove n stack = (* removes element at index n *) @@ -140,6 +151,7 @@ let remove n stack = | 0 -> I.[ drop ] | 1 -> I.[ swap; drop ] | n -> I.[ dig_n n; drop ] +;; let remove_sequence from count stack_init = (* removes count elements starting from index from *) @@ -154,29 +166,31 @@ let remove_sequence from count stack_init = (from : int) (count : int)] in - if List.length stack_right < count then + if List.length stack_right < count + then raise_s [%message "Instruction.remove_sequence: invalid stack" (stack_init : SlotStack.t) (from : int) (count : int)] - else - let stack = stack_left @ (List.drop stack_right count) in + else ( + let stack = stack_left @ List.drop stack_right count in let instructions = match count, from with | 0, _ -> [] | 1, 0 -> [ I.drop ] | 1, 1 -> [ I.swap; I.drop ] | 1, _ -> [ I.dig_n from; I.drop ] - | _ ,0 -> [ I.drop_n count ] - | _ , _-> (dip from (drop count) stack_init).instructions + | _, 0 -> [ I.drop_n count ] + | _, _ -> (dip from (drop count) stack_init).instructions in - Config.ok stack instructions + Config.ok stack instructions) +;; (* prim m n instr stack: m elements are consumed from the stack, n elements are produced *) let prim m n instr stack = - (M.pp Format.err_formatter instr); + M.pp Format.err_formatter instr; let stack = let left, right = List.split_n stack m in (* split stack into left and right at index m *) @@ -187,10 +201,15 @@ let prim m n instr stack = then raise_s [%message - "Instruction.prim: invalid stack" (stack : SlotStack.t) (m : int) (n : int) ((M.pp_string instr) : string)]; + "Instruction.prim: invalid stack" + (stack : SlotStack.t) + (m : int) + (n : int) + (M.pp_string instr : string)]; List.init n ~f:(fun _ -> `Value) @ right in Config.ok stack [ instr ] +;; let noop stack = Config.ok stack [] @@ -203,6 +222,7 @@ let loop (in_ : t) stack = in let instrs = Config.instructions @@ in_ stack in Config.ok stack [ I.loop instrs ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-LOOP_LEFT *) let loop_left (in_ : t) stack = @@ -213,14 +233,16 @@ let loop_left (in_ : t) stack = in let instrs = Config.instructions @@ in_ stack in Config.ok stack [ I.loop_left instrs ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-ITER *) let iter (in_ : t) stack = match stack with - | `Value :: stack -> + | `Value :: stack -> let instrs = Config.instructions @@ in_ (`Value :: stack) in Config.ok stack [ I.iter instrs ] | _ -> raise_s [%message "Instruction.iter" (stack : SlotStack.t)] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-MAP *) let map_ in_ stack = @@ -229,6 +251,7 @@ let map_ in_ stack = let instrs = Config.instructions @@ in_ stack in Config.ok stack [ I.map instrs ] | _ -> raise_s [%message "Instruction.map" (stack : SlotStack.t)] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-IF *) let if_ ~then_ ~else_ stack = @@ -239,14 +262,16 @@ let if_ ~then_ ~else_ stack = in Config.merge (then_ stack) (else_ stack) ~f:(fun instrs1 instrs2 -> [ I.if_ ~then_:instrs1 ~else_:instrs2 ]) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-IF_LEFT *) let if_left ~left ~right stack = match stack with - | `Value :: _ -> + | `Value :: _ -> Config.merge (left stack) (right stack) ~f:(fun instrs1 instrs2 -> [ I.if_left ~then_:instrs1 ~else_:instrs2 ]) | _ -> raise_s [%message "Instruction.if_left" (stack : SlotStack.t)] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-IF_CONS *) let if_cons ~empty ~nonempty stack = @@ -259,31 +284,43 @@ let if_cons ~empty ~nonempty stack = (nonempty (`Value :: `Value :: stack)) (empty stack) ~f:(fun instrs1 instrs2 -> [ I.if_cons ~then_:instrs1 ~else_:instrs2 ]) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-IF_NONE *) let if_none ~none ~some stack = match stack with - | `Value :: stack -> + | `Value :: stack -> Config.merge (none stack) (some (`Value :: stack)) ~f:(fun instrs1 instrs2 -> [ I.if_none ~then_:instrs1 ~else_:instrs2 ]) | _ -> raise_s [%message "Instruction.if_none" (stack : SlotStack.t)] +;; module Slot = struct let def (slot : [< Slot.definable ]) ~in_ stack = match stack with - | slot' :: stack when Slot.is_assignable slot' ~to_:slot -> + | slot' :: stack when Slot.is_assignable slot' ~to_:slot -> in_ ((slot :> Slot.t) :: stack) - | [] -> - raise_s [%message "Instruction.Slot.bind: invalid stack" (stack : SlotStack.t) (slot : [< Slot.definable ])] - | _ -> - raise_s [%message "Instruction.Slot.def: slot not assignable" (stack : SlotStack.t) (slot : [< Slot.definable ])] + | [] -> + raise_s + [%message + "Instruction.Slot.bind: invalid stack" + (stack : SlotStack.t) + (slot : [< Slot.definable ])] + | _ -> + raise_s + [%message + "Instruction.Slot.def: slot not assignable" + (stack : SlotStack.t) + (slot : [< Slot.definable ])] + ;; (* remove slot from stack, for example after it is used by let*) let collect slot stack = let found_slot = SlotStack.find_exn stack slot in remove found_slot stack + ;; let let_ slot ~in_ = seq [ def slot ~in_; collect slot ] (* bind and remove after used*) @@ -317,19 +354,21 @@ module Slot = struct raise_s [%message "Instruction.Slot.def_all: invalid stack" (stack : SlotStack.t)] in in_ stack + ;; (*let collect_all slots = seq (List.map slots ~f:collect)*) - let collect_all slots_seq = - if List.length slots_seq = 0 then - seq [] + let collect_all slots_seq = + if List.length slots_seq = 0 + then seq [] else - function stack -> + function + | stack -> (*raise_s [%message "Instruction.Slot.collect_all: collect_all invalid stack" (stack : SlotStack.t) (slots_seq : Slot.definable list)]*) let top_found_slot = SlotStack.find_exn stack (List.hd_exn slots_seq) in Printf.eprintf "top_found_slot: %d\n" top_found_slot; remove_sequence top_found_slot (List.length slots_seq) stack - + ;; let let_all slots ~in_ = seq [ def_all slots ~in_; collect_all slots ] (* bind and remove after used*) @@ -337,6 +376,7 @@ module Slot = struct let lookup slot ~in_ stack = let idx = SlotStack.find_exn stack slot in in_ idx stack + ;; let dup slot = lookup slot ~in_:(fun idx -> dup idx) @@ -355,10 +395,9 @@ module Slot = struct "Instruction.Slot.set: invalid stack" (stack : SlotStack.t) (slot : [< Slot.definable ])]) - - let mock_value stack = - Config.ok (`Value :: stack) [] + ;; + let mock_value stack = Config.ok (`Value :: stack) [] end (* https://tezos.gitlab.io/michelson-reference/#instr-UNPAIR, accepts 0 and 1 *) @@ -369,6 +408,7 @@ let unpair_n n = | 1 -> noop | 2 -> prim 1 2 I.unpair | n -> prim 1 n (I.unpair_n n) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-PAIR, accepts 0 and 1 *) let pair_n n = @@ -378,6 +418,7 @@ let pair_n n = | 1 -> noop | 2 -> prim 2 1 (I.pair ()) | n -> prim n 1 (I.pair_n n) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-GET *) (* Instead of using right-comb, the n represents just the number of leaves *) @@ -393,6 +434,7 @@ let get_n idx ~length:n = (* Convert idx to a right-comb index, needs special handling of last value *) let k = if idx = n - 1 then 2 * idx else (2 * idx) + 1 in prim 1 1 (I.get_n k) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-UPDATE *) (* Instead of using right-comb, the n represents just the number of leaves *) @@ -407,105 +449,135 @@ let update_n idx ~length:n = | n -> let k = if idx = n - 1 then 2 * idx else (2 * idx) + 1 in prim 2 1 (I.update_n k) +;; (* https://tezos.gitlab.io/michelson-reference/#instr-LAMBDA *) (* Lambdas used in LLTZ-IR do not use heaps. *) (* The environment specifies free variables that are used in the lambda. The environment variables need to be pushed on the stack before calling the lambda. *) let lambda ~environment ~lam_var ~return_type return stack = - let n = (List.length environment) + 1 in + let n = List.length environment + 1 in let environment_slots = List.map environment ~f:(fun (ident, _) -> `Ident ident) in let parameter_slot = `Ident (fst lam_var) in - let lambda_stack = [ `Value ] in let { Config.stack = _; instructions } = - let defined_slots = environment_slots @ [parameter_slot] in + let defined_slots = environment_slots @ [ parameter_slot ] in seq [ unpair_n n - ; Slot.def_all (defined_slots) ~in_:return - ; Slot.collect_all (defined_slots) + ; Slot.def_all defined_slots ~in_:return + ; Slot.collect_all defined_slots ] lambda_stack in - let parameter_type = - Type.tuple (List.map environment ~f:snd @ [snd lam_var]) - in + let parameter_type = Type.tuple (List.map environment ~f:snd @ [ snd lam_var ]) in Config.ok (`Value :: stack) [ I.lambda parameter_type return_type instructions ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-LAMBDA_REC *) (* Recursive version of lambda, mu is the name of the recursive variable *) let lambda_rec ~environment ~lam_var ~mu ~return_type return stack = - let n = (List.length environment) + 1 in + let n = List.length environment + 1 in let environment_slots = List.map environment ~f:(fun (ident, _) -> `Ident ident) in let parameter_slot = `Ident (fst lam_var) in - let lambda_stack = [ `Value; `Value ] in let { Config.stack = _; instructions } = - let defined_slots = environment_slots @ [parameter_slot] @ [`Ident mu] in + let defined_slots = environment_slots @ [ parameter_slot ] @ [ `Ident mu ] in seq - [ - unpair_n n - ; Slot.def_all (defined_slots) ~in_:return - ; Slot.collect_all (defined_slots) + [ unpair_n n + ; Slot.def_all defined_slots ~in_:return + ; Slot.collect_all defined_slots ] lambda_stack in - let parameter_type = - Type.tuple (List.map environment ~f:snd @ [snd lam_var]) - in + let parameter_type = Type.tuple (List.map environment ~f:snd @ [ snd lam_var ]) in Config.ok (`Value :: stack) [ I.lambda_rec parameter_type return_type instructions ] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-NEVER *) let never stack = match stack with | `Value :: _ -> Config.raise [ I.never ] | _ -> raise_s [%message "Instruction.never: invalid stack" (stack : SlotStack.t)] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-FAILWITH *) let failwith stack = match stack with | `Value :: _ -> Config.raise [ I.failwith ] | _ -> raise_s [%message "Instruction.failwith: invalid stack" (stack : SlotStack.t)] +;; (* https://tezos.gitlab.io/michelson-reference/#instr-CREATE_CONTRACT *) let create_contract ~storage ~parameter ~code stack = match stack with - | `Value :: `Value :: `Value :: stack -> - Config.ok (`Value :: `Value :: stack) [ I.create_contract storage parameter (code (`Value :: stack)) ] + | `Value :: `Value :: `Value :: stack -> + Config.ok + (`Value :: `Value :: stack) + [ I.create_contract storage parameter (code (`Value :: stack)) ] | _ -> - raise_s - [%message "Instruction.create_contract: invalid stack" (stack : SlotStack.t)] + raise_s [%message "Instruction.create_contract: invalid stack" (stack : SlotStack.t)] +;; + +let is_nat = + prim 1 1 I.is_nat (* https://tezos.gitlab.io/michelson-reference/#instr-ISNAT *) +;; -let is_nat = prim 1 1 I.is_nat (* https://tezos.gitlab.io/michelson-reference/#instr-ISNAT *) let unit = prim 0 1 I.unit (* https://tezos.gitlab.io/michelson-reference/#instr-UNIT *) -let push type_ lit = prim 0 1 (I.push type_ lit) (* https://tezos.gitlab.io/michelson-reference/#instr-PUSH *) -let apply = prim 2 1 I.apply (* https://tezos.gitlab.io/michelson-reference/#instr-APPLY *) +let push type_ lit = prim 0 1 (I.push type_ lit) + +(* https://tezos.gitlab.io/michelson-reference/#instr-PUSH *) +let apply = + prim 2 1 I.apply (* https://tezos.gitlab.io/michelson-reference/#instr-APPLY *) +;; + let exec = prim 2 1 I.exec (* https://tezos.gitlab.io/michelson-reference/#instr-EXEC *) -let unpair = prim 1 2 I.unpair (* https://tezos.gitlab.io/michelson-reference/#instr-UNPAIR *) + +let unpair = + prim 1 2 I.unpair (* https://tezos.gitlab.io/michelson-reference/#instr-UNPAIR *) +;; + let pack = prim 1 1 I.pack (* https://tezos.gitlab.io/michelson-reference/#instr-PACK *) let some = prim 1 1 I.some (* https://tezos.gitlab.io/michelson-reference/#instr-SOME *) -let update = prim 3 1 I.update (* https://tezos.gitlab.io/michelson-reference/#instr-UPDATE *) + +let update = + prim 3 1 I.update (* https://tezos.gitlab.io/michelson-reference/#instr-UPDATE *) +;; + let add = prim 2 1 I.add (* https://tezos.gitlab.io/michelson-reference/#instr-ADD *) let sub = prim 2 1 I.sub (* https://tezos.gitlab.io/michelson-reference/#instr-SUB *) let mul = prim 2 1 I.mul (* https://tezos.gitlab.io/michelson-reference/#instr-MUL *) -let pair = prim 2 1 (I.pair ()) (* https://tezos.gitlab.io/michelson-reference/#instr-PAIR *) +let pair = prim 2 1 (I.pair ()) + +(* https://tezos.gitlab.io/michelson-reference/#instr-PAIR *) let car = prim 1 1 I.car (* https://tezos.gitlab.io/michelson-reference/#instr-CAR *) let cdr = prim 1 1 I.cdr (* https://tezos.gitlab.io/michelson-reference/#instr-CDR *) let get = prim 2 1 I.get (* https://tezos.gitlab.io/michelson-reference/#instr-GET *) -let unpack type_ = prim 1 1 (I.unpack type_) (* https://tezos.gitlab.io/michelson-reference/#instr-UNPACK *) +let unpack type_ = prim 1 1 (I.unpack type_) + +(* https://tezos.gitlab.io/michelson-reference/#instr-UNPACK *) let neg = prim 1 1 I.neg (* https://tezos.gitlab.io/michelson-reference/#instr-NEG *) let ediv = prim 2 1 I.ediv (* https://tezos.gitlab.io/michelson-reference/#instr-EDIV *) let failwithf fmt = Fmt.kstr (fun msg -> seq [ push T.string (M.string msg); failwith ]) fmt +;; let and_ = prim 2 1 I.and_ (* https://tezos.gitlab.io/michelson-reference/#instr-AND *) let or_ = prim 2 1 I.or_ (* https://tezos.gitlab.io/michelson-reference/#instr-OR *) -let not = prim 1 1 I.not (* https://tezos.gitlab.io/michelson-reference/#instr-NOT *) -let left type_ = prim 1 1 (I.left type_) (* https://tezos.gitlab.io/michelson-reference/#instr-LEFT *) -let right type_ = prim 1 1 (I.right type_) (* https://tezos.gitlab.io/michelson-reference/#instr-RIGHT *) -let empty_map key_type val_type = prim 0 1 (I.empty_map key_type val_type) (* https://tezos.gitlab.io/michelson-reference/#instr-EMPTY_MAP *) -let compare = prim 2 1 I.compare (* https://tezos.gitlab.io/michelson-reference/#instr-COMPARE *) +let not = prim 1 1 I.not (* https://tezos.gitlab.io/michelson-reference/#instr-NOT *) +let left type_ = prim 1 1 (I.left type_) + +(* https://tezos.gitlab.io/michelson-reference/#instr-LEFT *) +let right type_ = prim 1 1 (I.right type_) + +(* https://tezos.gitlab.io/michelson-reference/#instr-RIGHT *) +let empty_map key_type val_type = prim 0 1 (I.empty_map key_type val_type) + +(* https://tezos.gitlab.io/michelson-reference/#instr-EMPTY_MAP *) +let compare = + prim 2 1 I.compare (* https://tezos.gitlab.io/michelson-reference/#instr-COMPARE *) +;; + let eq = prim 1 1 I.eq (* https://tezos.gitlab.io/michelson-reference/#instr-EQ *) let neq = prim 1 1 I.neq (* https://tezos.gitlab.io/michelson-reference/#instr-NEQ *) let lt = prim 1 1 I.lt (* https://tezos.gitlab.io/michelson-reference/#instr-LT *) @@ -513,7 +585,9 @@ let le = prim 1 1 I.le (* https://tezos.gitlab.io/michelson-reference/#instr-LE let gt = prim 1 1 I.gt (* https://tezos.gitlab.io/michelson-reference/#instr-GT *) let ge = prim 1 1 I.ge (* https://tezos.gitlab.io/michelson-reference/#instr-GE *) let int = prim 1 1 I.int (* https://tezos.gitlab.io/michelson-reference/#instr-INT *) -let nil type_ = prim 0 1 (I.nil type_) (* https://tezos.gitlab.io/michelson-reference/#instr-NIL *) +let nil type_ = prim 0 1 (I.nil type_) + +(* https://tezos.gitlab.io/michelson-reference/#instr-NIL *) let cons = prim 2 1 I.cons (* https://tezos.gitlab.io/michelson-reference/#instr-CONS *) let debug = ref false let next_trace_point = ref (-1) @@ -521,15 +595,24 @@ let next_trace_point = ref (-1) (* Directly using michelson specified via micheline. Can take arbitrary number of args and return a single value. *) let raw_michelson michelson args stack = let n = List.length args in - if List.length stack < n then - raise_s [%message "Instruction.raw_michelson: invalid stack" (stack : SlotStack.t) (n : int)] - else + if List.length stack < n + then + raise_s + [%message + "Instruction.raw_michelson: invalid stack" (stack : SlotStack.t) (n : int)] + else ( let top_elements = List.take stack n in - if List.for_all top_elements ~f:(function `Value -> true | _ -> false) then - let new_stack = `Value :: (List.drop stack n) in - Config.ok new_stack michelson + if List.for_all top_elements ~f:(function + | `Value -> true + | _ -> false) + then ( + let new_stack = `Value :: List.drop stack n in + Config.ok new_stack michelson) else - raise_s [%message "Instruction.raw_michelson: invalid stack" (stack : SlotStack.t) (n : int)] + raise_s + [%message + "Instruction.raw_michelson: invalid stack" (stack : SlotStack.t) (n : int)]) +;; let set_debug next in_ = let curr = !debug in @@ -537,15 +620,18 @@ let set_debug next in_ = let result = in_ () in debug := curr; result +;; let to_michelson t stack ~debug = set_debug debug (fun () -> let Config.{ stack = _; instructions } = t stack in instructions) +;; let print_s sexp stack = - if !debug then Printf.eprintf "%s\n" (Sexp.to_string_hum (sexp)); + if !debug then Printf.eprintf "%s\n" (Sexp.to_string_hum sexp); Config.ok stack [] +;; let trace ?(flag = "") t = let trace_point = @@ -554,8 +640,17 @@ let trace ?(flag = "") t = in seq [ (fun stack -> - print_s [%message (stack : SlotStack.t) (String.concat [(Int.to_string trace_point); "=before "; flag;])] stack) + print_s + [%message + (stack : SlotStack.t) + (String.concat [ Int.to_string trace_point; "=before "; flag ])] + stack) ; t ; (fun stack -> - print_s [%message (stack : SlotStack.t) (String.concat [(Int.to_string trace_point); "=after "; flag;])] stack) + print_s + [%message + (stack : SlotStack.t) + (String.concat [ Int.to_string trace_point; "=after "; flag ])] + stack) ] +;; diff --git a/lib/lltz_codegen/lltz_codegen.ml b/lib/lltz_codegen/lltz_codegen.ml index 9afe09a..aa99b1e 100644 --- a/lib/lltz_codegen/lltz_codegen.ml +++ b/lib/lltz_codegen/lltz_codegen.ml @@ -7,7 +7,6 @@ module Stack = Stack module Type = Type module Instruction = Instruction module Slot = Slot - open Core module LLTZ = struct @@ -29,11 +28,13 @@ open Tezos_micheline let rec compile_row_types row = match row with - | LLTZ.R.Node nodes -> - let annots = List.map nodes ~f:( - fun node -> match node with - | LLTZ.R.Leaf(Some (LLTZ.R.Label value),_) -> Some(value) - | _ -> None) in + | LLTZ.R.Node nodes -> + let annots = + List.map nodes ~f:(fun node -> + match node with + | LLTZ.R.Leaf (Some (LLTZ.R.Label value), _) -> Some value + | _ -> None) + in Type.tuple (List.map nodes ~f:compile_row_types) ~annots | LLTZ.R.Leaf (_, value) -> convert_type value @@ -41,10 +42,12 @@ and compile_row_types_for_or row = match row with | LLTZ.R.Node nodes -> let converted_types = List.map nodes ~f:compile_row_types_for_or in - let annots = List.map nodes ~f:( - fun node -> match node with - | LLTZ.R.Leaf(Some (LLTZ.R.Label value),_) -> Some (value) - | _ -> None) in + let annots = + List.map nodes ~f:(fun node -> + match node with + | LLTZ.R.Leaf (Some (LLTZ.R.Label value), _) -> Some value + | _ -> None) + in Type.ors converted_types ~annots | LLTZ.R.Leaf (_, value) -> convert_type value @@ -89,9 +92,9 @@ and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = match const with | Unit -> Michelson.Ast.Instruction.unit | Bool b -> if b then Michelson.Ast.true_ else Michelson.Ast.false_ - | Nat n -> Michelson.Ast.int_of_z (n) - | Int n -> Michelson.Ast.int_of_z (n) - | Mutez n -> Michelson.Ast.int_of_z (n) + | Nat n -> Michelson.Ast.int_of_z n + | Int n -> Michelson.Ast.int_of_z n + | Mutez n -> Michelson.Ast.int_of_z n | String s -> Michelson.Ast.string s | Key s -> Michelson.Ast.string s | Key_hash s -> Michelson.Ast.string s @@ -176,7 +179,7 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Keccak -> keccak | Sha3 -> sha3 | Set_delegate -> set_delegate - | Read_ticket -> Michelson.Ast.seq [read_ticket; pair ()] + | Read_ticket -> Michelson.Ast.seq [ read_ticket; pair () ] | Join_tickets -> join_tickets | Pairing_check -> pairing_check | Voting_power -> voting_power @@ -213,23 +216,23 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | View (name, ty) -> view name (convert_type ty) | Slice -> slice | Update -> update - | Get_and_update -> Michelson.Ast.seq [get_and_update; pair ()] + | Get_and_update -> Michelson.Ast.seq [ get_and_update; pair () ] | Transfer_tokens -> transfer_tokens | Check_signature -> check_signature | Open_chest -> open_chest ;; let rec compile : LLTZ.E.t -> t = - fun expr -> + fun expr -> seq [ (match expr.desc with | Variable (Var name) -> compile_variable name | Let_in { let_var = Var var; rhs; in_ } -> compile_let_in var rhs in_ - | Lambda { lam_var = Var var, lam_var_type; body } -> - compile_lambda expr + | Lambda { lam_var = Var var, lam_var_type; body } -> compile_lambda expr | Lambda_rec - { mu_var = Var mu, mu_type; lambda = {lam_var = Var var, lam_var_type; body} } -> - compile_lambda_rec expr + { mu_var = Var mu, mu_type + ; lambda = { lam_var = Var var, lam_var_type; body } + } -> compile_lambda_rec expr | App { abs; arg } -> compile_app abs arg | Const constant -> compile_const constant | Prim (primitive, args) -> compile_prim primitive args @@ -238,32 +241,51 @@ let rec compile : LLTZ.E.t -> t = | Assign (Mut_var var, value) -> compile_assign var value | If_bool { condition; if_true; if_false } -> compile_if_bool condition if_true if_false - | If_none { subject; if_none; if_some = {lam_var = Var var; body = some} } -> + | If_none { subject; if_none; if_some = { lam_var = Var var; body = some } } -> compile_if_none subject if_none (var, some) - | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body =nonempty }} -> - compile_if_cons subject if_empty (hd, tl, nonempty) - | If_left { subject; if_left = {lam_var = Var left; body =l}; if_right = {lam_var = Var right; body = r} } -> - compile_if_left subject (left, l) (right, r) + | If_cons + { subject + ; if_empty + ; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body = nonempty } + } -> compile_if_cons subject if_empty (hd, tl, nonempty) + | If_left + { subject + ; if_left = { lam_var = Var left; body = l } + ; if_right = { lam_var = Var right; body = r } + } -> compile_if_left subject (left, l) (right, r) | While { cond; body } -> compile_while cond body - | While_left { cond; body = {lam_var = Var var; body=body_lambda} } -> compile_while_left cond var body_lambda expr.type_ + | While_left { cond; body = { lam_var = Var var; body = body_lambda } } -> + compile_while_left cond var body_lambda expr.type_ | For { index = Mut_var var; init; cond; update; body } -> compile_for var init cond update body - | For_each { collection; body = {lam_var = Var var; body = lambda_body} } -> + | For_each { collection; body = { lam_var = Var var; body = lambda_body } } -> compile_for_each collection var lambda_body - | Map { collection; map = {lam_var = Var var; body=lam_body} } -> compile_map collection var lam_body - | Fold_left { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> - compile_fold_left collection init_body var fold_body - | Fold_right { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } - -> compile_fold_right collection init_body var fold_body + | Map { collection; map = { lam_var = Var var; body = lam_body } } -> + compile_map collection var lam_body + | Fold_left + { collection + ; init = init_body + ; fold = { lam_var = Var var; body = fold_body } + } -> compile_fold_left collection init_body var fold_body + | Fold_right + { collection + ; init = init_body + ; fold = { lam_var = Var var; body = fold_body } + } -> compile_fold_right collection init_body var fold_body | Let_tuple_in { components; rhs; in_ } -> compile_let_tuple_in components rhs in_ | Tuple row -> compile_tuple row - | Proj (tuple, path) ->compile_proj tuple path + | Proj (tuple, path) -> compile_proj tuple path | Update { tuple; component; update } -> compile_update tuple component update | Inj (path, expr) -> compile_inj path expr | Match (subject, cases) -> compile_match subject cases - | Raw_michelson {michelson; args} -> compile_raw_michelson michelson args + | Raw_michelson { michelson; args } -> compile_raw_michelson michelson args | Create_contract - { storage; code = {lam_var = Var param_var, param_ty ;body =code_body}; delegate; initial_balance; initial_storage } -> + { storage + ; code = { lam_var = Var param_var, param_ty; body = code_body } + ; delegate + ; initial_balance + ; initial_storage + } -> compile_create_contract storage param_var @@ -275,42 +297,53 @@ let rec compile : LLTZ.E.t -> t = | Global_constant hash -> assert false) ] -and compile_contract (input_var: string) (code: LLTZ.E.t) = +and compile_contract (input_var : string) (code : LLTZ.E.t) = let code_instr = compile code in - seq [ Slot.mock_value; Slot.let_ (`Ident input_var) ~in_:code_instr; ] + seq [ Slot.mock_value; Slot.let_ (`Ident input_var) ~in_:code_instr ] (* Compile a variable by duplicating its value on the stack. *) -and compile_variable (name : string) = trace ~flag: (String.append "var " name) (Slot.dup (`Ident name)) +and compile_variable (name : string) = + trace ~flag:(String.append "var " name) (Slot.dup (`Ident name)) (* Compile a let-in expression by compiling the right-hand side, then binding the result to the variable in the inner expression. *) and compile_let_in (var : string) (rhs : LLTZ.E.t) (in_ : LLTZ.E.t) = - trace ~flag: (String.append "let in " var) (seq [ compile rhs; Slot.let_ (`Ident var) ~in_:(compile in_);]) + trace + ~flag:(String.append "let in " var) + (seq [ compile rhs; Slot.let_ (`Ident var) ~in_:(compile in_) ]) (* Compile a mutable let-in expression by compiling the right-hand side, then binding the result to the mutable variable in the inner expression. *) and compile_mut_let_in (var : string) (rhs : LLTZ.E.t) (in_ : LLTZ.E.t) = - trace ~flag: (String.append "let_mut in " var) (seq [ compile rhs; Slot.let_ (`Ident var) ~in_:(compile in_) ]) + trace + ~flag:(String.append "let_mut in " var) + (seq [ compile rhs; Slot.let_ (`Ident var) ~in_:(compile in_) ]) (* Compile a constant by pushing its value onto the stack. *) and compile_const constant = - (match constant with - | LLTZ.E.Unit -> seq [ unit;] - | _ -> seq [ push (get_const_type constant) (convert_constant constant) ]) + match constant with + | LLTZ.E.Unit -> seq [ unit ] + | _ -> seq [ push (get_const_type constant) (convert_constant constant) ] (* Compile a primitive by compiling its arguments, then applying the primitive to the arguments. *) and compile_prim primitive args = let args_instrs = List.map ~f:compile args in match primitive with - | LLTZ.P.Failwith -> seq (List.rev_append (args_instrs) [Instruction.failwith]) - | LLTZ.P.Never -> seq (List.rev_append (args_instrs) [Instruction.never]) + | LLTZ.P.Failwith -> seq (List.rev_append args_instrs [ Instruction.failwith ]) + | LLTZ.P.Never -> seq (List.rev_append args_instrs [ Instruction.never ]) | _ -> - trace ~flag:((Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive))) (seq (List.rev_append (args_instrs) [ prim (List.length args) 1 (convert_primitive primitive) ])) + trace + ~flag:(Sexp.to_string_hum (LLTZ.P.sexp_of_t primitive)) + (seq + (List.rev_append + args_instrs + [ prim (List.length args) 1 (convert_primitive primitive) ])) (* Compile a dereference by duplicating the value of the mutable variable on the stack. *) -and compile_deref (var : string) = trace ~flag:(String.append "mut_var " var) (Slot.dup (`Ident var)) +and compile_deref (var : string) = + trace ~flag:(String.append "mut_var " var) (Slot.dup (`Ident var)) (* Compile an assignment by compiling the value to be assigned, then assigning it to the slot corresponding to the mutable variable. *) and compile_assign (var : string) value = - trace ~flag:"assign" (seq [ trace (compile value); Slot.set (`Ident var); unit]) + trace ~flag:"assign" (seq [ trace (compile value); Slot.set (`Ident var); unit ]) (* Compile an if-bool expression by compiling the condition, then applying the if-bool instruction to the condition and the true and false branches. *) and compile_if_bool condition if_true if_false = @@ -349,8 +382,12 @@ and compile_while invariant body = seq [ compile invariant; loop (seq [ compile body; drop 1; compile invariant ]); unit ] (* Compile a while-left expression by compiling the invariant, then applying the loop-left instruction to the body and invariant. *) -and compile_while_left init_val var body_lambda res_ty= - seq [ compile init_val; left (convert_type res_ty); loop_left (seq [ Slot.let_ (`Ident var) ~in_:(compile body_lambda); ]); ] +and compile_while_left init_val var body_lambda res_ty = + seq + [ compile init_val + ; left (convert_type res_ty) + ; loop_left (seq [ Slot.let_ (`Ident var) ~in_:(compile body_lambda) ]) + ] (* Compile a for expression by compiling the initial value, invariant, variant, and body, then applying the loop to the sequence of body, variant, and invariant. *) @@ -358,33 +395,37 @@ and compile_for index init invariant variant body = let init_instr = compile init in let inv_instr = compile invariant in seq - [ init_instr; - Slot.let_ (`Ident index) ~in_: - (seq [ - inv_instr - ; loop - (seq [ compile body; drop 1; compile variant; drop 1; inv_instr ]) - ]); - unit + [ init_instr + ; Slot.let_ + (`Ident index) + ~in_: + (seq + [ inv_instr + ; loop (seq [ compile body; drop 1; compile variant; drop 1; inv_instr ]) + ]) + ; unit ] (* Compile a tuple expression by compiling each component and pairing them together. *) and compile_tuple row = - trace ~flag:"tuple" (match row with - | LLTZ.R.Node nodes -> - let compiled_nodes = List.map ~f:compile_tuple nodes in - seq ((List.rev_append (compiled_nodes)) [ pair_n (List.length compiled_nodes) ]) - | LLTZ.R.Leaf (_, value) -> compile value) + trace + ~flag:"tuple" + (match row with + | LLTZ.R.Node nodes -> + let compiled_nodes = List.map ~f:compile_tuple nodes in + seq ((List.rev_append compiled_nodes) [ pair_n (List.length compiled_nodes) ]) + | LLTZ.R.Leaf (_, value) -> compile value) (* Compile a projection expression by compiling the tuple and then getting the nth element. *) and compile_proj tuple path = let _, gets, tuple_expanded_instr = expand_tuple tuple path in - trace ~flag:"proj" + trace + ~flag:"proj" (seq ([ trace ~flag:"proj expansion" tuple_expanded_instr ] - @ [ (* Keep the last value, drop the intermediate ones and the tuple *) - trace ~flag:"proj dropping" (dip 1 (drop (List.length gets))) - ])) + @ [ (* Keep the last value, drop the intermediate ones and the tuple *) + trace ~flag:"proj dropping" (dip 1 (drop (List.length gets))) + ])) (* Compile an update expression by compiling the tuple row, getting the nth element, compiling the update value, and combining the values back together into tuple. *) and compile_update tuple component update = @@ -395,7 +436,7 @@ and compile_update tuple component update = | LLTZ.R.Path.Here list -> List.mapi list ~f:(fun i num -> match List.nth lengths i with - | Some length -> (update_n num ~length;) + | Some length -> update_n num ~length | None -> raise_s [%message @@ -403,7 +444,13 @@ and compile_update tuple component update = (i : int) (lengths : int list)])) in - trace ~flag:"update" (seq ([ compile tuple ] @ [trace ~flag:"gets" (seq(gets))] @ [drop 1; compile update ] @ [trace ~flag:"updates" (seq(updates))])) + trace + ~flag:"update" + (seq + ([ compile tuple ] + @ [ trace ~flag:"gets" (seq gets) ] + @ [ drop 1; compile update ] + @ [ trace ~flag:"updates" (seq updates) ])) and get_lengths_inner row path_list = match row with @@ -424,7 +471,7 @@ and get_lengths_inner row path_list = (* Get the number of children for each node on the path *) and get_tuple_lengths tuple path = match LLTZ.E.(tuple.type_), path with - | {desc = LLTZ.T.Tuple row; _}, LLTZ.R.Path.Here list -> get_lengths_inner row list + | { desc = LLTZ.T.Tuple row; _ }, LLTZ.R.Path.Here list -> get_lengths_inner row list | _ -> raise_s [%message "Tuple expected"] (* Expand a tuple expression to a sequence of instructions that get the nth element *) @@ -435,7 +482,7 @@ and expand_tuple tuple path = let (LLTZ.R.Path.Here list) = path in List.mapi list ~f:(fun i num -> match List.nth lengths i with - | Some length -> seq [dup 0; get_n num ~length] + | Some length -> seq [ dup 0; get_n num ~length ] | None -> raise_s [%message "Index out of bounds" (i : int) (lengths : int list)]) in lengths, gets, seq ([ compile tuple ] @ gets) @@ -444,11 +491,13 @@ and expand_tuple tuple path = and compile_let_tuple_in components rhs in_ = let rhs_instr = compile rhs in let new_env = List.map components ~f:(fun (Var var) -> `Ident var) in - trace ~flag: "let tuple in" (seq - [ rhs_instr - ; unpair_n (List.length components) - ; trace (Slot.let_all new_env ~in_:(compile in_)) - ]) + trace + ~flag:"let tuple in" + (seq + [ rhs_instr + ; unpair_n (List.length components) + ; trace (Slot.let_all new_env ~in_:(compile in_)) + ]) (* Compile lambda expression by compiling the body and creating a lambda instruction. *) and compile_lambda expr = @@ -457,9 +506,7 @@ and compile_lambda expr = let lam_var = var, convert_type lam_var_type in let return_type = convert_type body.type_ in let environment = - LLTZ.Free_vars.free_vars_with_types expr - |> Map.map ~f:convert_type - |> Map.to_alist + LLTZ.Free_vars.free_vars_with_types expr |> Map.map ~f:convert_type |> Map.to_alist in seq ([ lambda ~environment ~lam_var ~return_type (compile body) ] @@ -470,14 +517,12 @@ and compile_lambda expr = (* Compile lambda-rec expression by compiling the body and creating a lambda-rec instruction. *) and compile_lambda_rec expr = match expr.desc with - | Lambda_rec { mu_var = Var mu, mu_type; lambda = {lam_var = Var var, lam_var_type; body} } -> + | Lambda_rec + { mu_var = Var mu, mu_type; lambda = { lam_var = Var var, lam_var_type; body } } -> let lam_var = var, convert_type lam_var_type in let return_type = convert_type body.type_ in - let environment = - LLTZ.Free_vars.free_vars_with_types expr - |> Map.map ~f:convert_type - |> Map.to_alist + LLTZ.Free_vars.free_vars_with_types expr |> Map.map ~f:convert_type |> Map.to_alist in seq ([ lambda_rec ~environment ~lam_var ~mu ~return_type (compile body) ] @@ -487,7 +532,7 @@ and compile_lambda_rec expr = (* Compile an application by compiling a lambda and argument, then applying the EXEC instruction. *) and compile_app abs arg = - (Instruction.seq [ trace (compile abs); trace (compile arg); trace ~flag:"exec" exec ]) + Instruction.seq [ trace (compile abs); trace (compile arg); trace ~flag:"exec" exec ] (* Compile contract creation expression by compiling the delegate, initial balance, and initial storage, applying CREATE_CONTRACT instruction. *) and compile_create_contract @@ -502,39 +547,34 @@ and compile_create_contract let storage_ty = convert_type storage in let param_ty = convert_type param_ty in Printf.eprintf "param_var: %s\n" param_var; - let code_instr = seq[Slot.let_ (`Ident param_var) ~in_:(compile code_body)] in + let code_instr = seq [ Slot.let_ (`Ident param_var) ~in_:(compile code_body) ] in Printf.eprintf "woohoo\n"; - trace ~flag:"create_contract" ( - seq - [ compile delegate - ; compile initial_balance - ; compile initial_storage - ; create_contract ~storage:storage_ty ~parameter:param_ty ~code:(fun stack -> - M.seq (code_instr stack).instructions) - ; trace ~flag:"pair woohoo" (pair) - ] - ) + trace + ~flag:"create_contract" + (seq + [ compile delegate + ; compile initial_balance + ; compile initial_storage + ; create_contract ~storage:storage_ty ~parameter:param_ty ~code:(fun stack -> + M.seq (code_instr stack).instructions) + ; trace ~flag:"pair woohoo" pair + ]) (* Compile for-each expression by compiling the collection, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the body. *) and compile_for_each collection var body = let coll_instr = compile collection in - trace ~flag:"for_each " (seq - [ coll_instr - ; iter - (seq - [ - Slot.let_ (`Ident var) ~in_:(seq [ compile body; drop 1 ]); - ]) - ; unit - ]) + trace + ~flag:"for_each " + (seq + [ coll_instr + ; iter (seq [ Slot.let_ (`Ident var) ~in_:(seq [ compile body; drop 1 ]) ]) + ; unit + ]) (* Compile map expression by compiling the collection, then applying the MAP instruction that maps over the collection and binds the values to the variables in the function body. *) and compile_map collection var lam_body = let coll_instr = compile collection in - seq - [ coll_instr - ; map_ (seq [ Slot.let_ (`Ident var) ~in_:(compile lam_body) ]) - ] + seq [ coll_instr; map_ (seq [ Slot.let_ (`Ident var) ~in_:(compile lam_body) ]) ] (* Compile fold-left expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) and compile_fold_left collection init_body var fold_body = @@ -544,10 +584,12 @@ and compile_fold_left collection init_body var fold_body = [ init_instr ; coll_instr ; iter - (seq [ - swap; - pair; (* Creates pair (acc, val) *) - Slot.let_ (`Ident var) ~in_:(compile fold_body); ]) + (seq + [ swap + ; pair + ; (* Creates pair (acc, val) *) + Slot.let_ (`Ident var) ~in_:(compile fold_body) + ]) ] (* Compile fold-right expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) @@ -559,19 +601,23 @@ and compile_fold_right collection init_body var fold_body = ; coll_instr ; nil (convert_type (get_coll_elem_type collection)) ; swap + ; iter (seq [ cons ]) ; iter - (seq [ cons; ]) - ; iter - (seq [ - pair; (* Creates pair (val, acc) *) - Slot.let_ (`Ident var) ~in_:(compile fold_body); ]) + (seq + [ pair + ; (* Creates pair (val, acc) *) + Slot.let_ (`Ident var) ~in_:(compile fold_body) + ]) ] and get_coll_elem_type collection = match collection.type_.desc with | List ty -> ty | Set ty -> ty - | Map (key, value) -> LLTZ.Dsl.tuple_ty ~range:collection.range (LLTZ.R.Node[ LLTZ.R.Leaf (None,key); LLTZ.R.Leaf(None,value) ]) + | Map (key, value) -> + LLTZ.Dsl.tuple_ty + ~range:collection.range + (LLTZ.R.Node [ LLTZ.R.Leaf (None, key); LLTZ.R.Leaf (None, value) ]) | _ -> raise_s [%message "Collection expected"] and compile_inj context expr = @@ -595,22 +641,23 @@ and compile_inj context expr = | [] -> raise_s [%message "Empty list"]) ~init:[ Type.ors [ mid_ty; right_ty ] ] in - trace ~flag:"inj" (seq - ([ compile expr; (* Left *) left mid_ty ] - (* Rights - traverses all right_instrs_types in reverse order except last and makes right*) - @ - if List.length right_instrs_types = 0 - then [] - else - List.map (List.rev (List.tl_exn right_instrs_types)) ~f:(fun ty -> right ty) - )) + trace + ~flag:"inj" + (seq + ([ compile expr; (* Left *) left mid_ty ] + (* Rights - traverses all right_instrs_types in reverse order except last and makes right*) + @ + if List.length right_instrs_types = 0 + then [] + else List.map (List.rev (List.tl_exn right_instrs_types)) ~f:(fun ty -> right ty) + )) and compile_row_of_lambdas row = match row with | LLTZ.R.Node nodes -> let compiled_nodes = List.map nodes ~f:compile_row_of_lambdas in Instruction.seq (compiled_nodes @ [ Instruction.pair_n (List.length compiled_nodes) ]) - | LLTZ.R.Leaf (_, LLTZ.E.{lam_var = Var var, var_type; body}) -> + | LLTZ.R.Leaf (_, LLTZ.E.{ lam_var = Var var, var_type; body }) -> compile (LLTZ.Dsl.lambda (Var var, var_type) ~body) and compile_match subject cases = @@ -630,23 +677,31 @@ and compile_matching cases = [ if_left ~left:(compile_matching hd) ~right:(compile_matching (LLTZ.R.Node tl)) ] | [] -> seq []) - | LLTZ.R.Leaf (_, {lam_var = Var var, var_type; body}) -> + | LLTZ.R.Leaf (_, { lam_var = Var var, var_type; body }) -> seq [ compile (LLTZ.Dsl.lambda (Var var, var_type) ~body); exec ] and compile_raw_michelson michelson args = - let michelson = Micheline.map_node (fun _ -> ()) (fun prim -> Michelson.Ast.Prim.of_string prim) michelson in + let michelson = + Micheline.map_node + (fun _ -> ()) + (fun prim -> Michelson.Ast.Prim.of_string prim) + michelson + in let args_instrs = List.map ~f:compile args in - trace ~flag:"raw_michelson" (seq (List.rev_append (args_instrs) [ raw_michelson [michelson] args ])) + trace + ~flag:"raw_michelson" + (seq (List.rev_append args_instrs [ raw_michelson [ michelson ] args ])) +;; (* Compile and additionally convert to a single micheline node *) -let compile_to_micheline expr stack= +let compile_to_micheline expr stack = let compiled = compile expr in let micheline = Michelson.Ast.seq (compiled stack).instructions in micheline +;; -let compile_contract_to_micheline input_var expr= +let compile_contract_to_micheline input_var expr = let compiled = compile_contract input_var expr in let micheline = Michelson.Ast.seq (compiled []).instructions in micheline - - +;; diff --git a/lib/lltz_codegen/slot.ml b/lib/lltz_codegen/slot.ml index a4202bb..d6e2b86 100644 --- a/lib/lltz_codegen/slot.ml +++ b/lib/lltz_codegen/slot.ml @@ -16,3 +16,4 @@ let is_assignable (from : t) ~(to_ : [< definable ]) = | `Heap, `Ident (_ : string) -> false | `Value, _ -> true | `Ident _, _ -> false +;; diff --git a/lib/lltz_codegen/stack.ml b/lib/lltz_codegen/stack.ml index 461c15b..5a6c951 100644 --- a/lib/lltz_codegen/stack.ml +++ b/lib/lltz_codegen/stack.ml @@ -5,8 +5,8 @@ type t = Slot.t list [@@deriving equal, compare, sexp] let empty = [] let find t slot = - List.findi t ~f:(fun _i slot' -> Slot.equal (slot :> Slot.t) slot') - |> Option.map ~f:fst + List.findi t ~f:(fun _i slot' -> Slot.equal (slot :> Slot.t) slot') |> Option.map ~f:fst +;; let find_exn t slot = (*debug output*) @@ -15,20 +15,19 @@ let find_exn t slot = | None -> raise_s [%message - "Instruction.Stack.find_exn: slot not found" - (t : t) - (slot : Slot.definable)] + "Instruction.Stack.find_exn: slot not found" (t : t) (slot : Slot.definable)] +;; - (* merge two stacks, if a slot is `Ident in both stacks, it must be the same ident *) +(* merge two stacks, if a slot is `Ident in both stacks, it must be the same ident *) let merge t1 t2 : t = match List.map2 t1 t2 ~f:(fun slot1 slot2 -> - match slot1, slot2 with - | `Ident x, `Ident y when Ident.(x = y) -> `Ident x - | `Heap, `Heap -> `Heap - | _ -> `Value) + match slot1, slot2 with + | `Ident x, `Ident y when Ident.(x = y) -> `Ident x + | `Heap, `Heap -> `Heap + | _ -> `Value) with | Ok t -> t | Unequal_lengths -> - raise_s - [%message "Stack.join: cannot join stacks of unequal size" (t1 : t) (t2 : t)] \ No newline at end of file + raise_s [%message "Stack.join: cannot join stacks of unequal size" (t1 : t) (t2 : t)] +;; diff --git a/lib/lltz_codegen/type.ml b/lib/lltz_codegen/type.ml index 389f32c..d4ae3d2 100644 --- a/lib/lltz_codegen/type.ml +++ b/lib/lltz_codegen/type.ml @@ -1,4 +1,4 @@ -module M = Lltz_michelson.Ast +module M = Lltz_michelson.Ast module T = M.Type let tuple ?(annots = []) types = @@ -7,11 +7,12 @@ let tuple ?(annots = []) types = match types, annots with | [], [] -> assert false | [ type1 ], _ -> type1 - | [], _::_ -> assert false - | [ type1; type2 ], [annot1; annot2] -> T.pair ~annot1 ~annot2 type1 type2 - | [ type1; type2 ], [annot1] -> T.pair ~annot1 type1 type2 + | [], _ :: _ -> assert false + | [ type1; type2 ], [ annot1; annot2 ] -> T.pair ~annot1 ~annot2 type1 type2 + | [ type1; type2 ], [ annot1 ] -> T.pair ~annot1 type1 type2 | [ type1; type2 ], _ -> T.pair type1 type2 - | type_ :: types, annot1::tl_annots -> T.pair ~annot1 type_ (loop types ~annots:tl_annots) + | type_ :: types, annot1 :: tl_annots -> + T.pair ~annot1 type_ (loop types ~annots:tl_annots) | type_ :: types, _ -> T.pair type_ (loop types) in loop types ~annots @@ -21,12 +22,13 @@ let ors ?(annots = []) types = (* Right-comb encoding of or-types (not efficient, but cheap) *) let rec loop ?(annots = []) types = match types, annots with - | [], [] | [ _ ], [ _ ]| [], _::_ -> assert false - | [ type1; type2 ], [annot1; annot2] -> T.or_ ~annot1 ~annot2 type1 type2 - | [ type1; type2 ], [annot1] -> T.or_ ~annot1 type1 type2 + | [], [] | [ _ ], [ _ ] | [], _ :: _ -> assert false + | [ type1; type2 ], [ annot1; annot2 ] -> T.or_ ~annot1 ~annot2 type1 type2 + | [ type1; type2 ], [ annot1 ] -> T.or_ ~annot1 type1 type2 | [ type1; type2 ], _ -> T.or_ type1 type2 - | type_ :: types, annot1::tl_annots -> T.or_ ~annot1 type_ (loop types ~annots:tl_annots) + | type_ :: types, annot1 :: tl_annots -> + T.or_ ~annot1 type_ (loop types ~annots:tl_annots) | type_ :: types, _ -> T.or_ type_ (loop types) in loop types ~annots -;; \ No newline at end of file +;; diff --git a/lib/lltz_ir/dsl.ml b/lib/lltz_ir/dsl.ml index fd330d4..f2ed27e 100644 --- a/lib/lltz_ir/dsl.ml +++ b/lib/lltz_ir/dsl.ml @@ -2,7 +2,7 @@ This file adds a domain specific language (DSL), consisting of functions for easier creation of expressions using LLTZ-IR. *) open Grace -open Core +open Core module LLTZ = struct module E = Expr @@ -17,54 +17,107 @@ type mut_var = Mut_var of string let dummy : Range.t = Range.initial (`String { content = ""; name = Some "" }) (* Creation with optional range *) -let create ?(range = dummy) desc type_ = LLTZ.E.{ desc; range; type_} -let mk_type ?(range=dummy) (desc: LLTZ.T.desc) : LLTZ.T.t = { desc; range} +let create ?(range = dummy) desc type_ = LLTZ.E.{ desc; range; type_ } +let mk_type ?(range = dummy) (desc : LLTZ.T.desc) : LLTZ.T.t = { desc; range } -let rec get_type_row (row: LLTZ.E.t Row.t) : LLTZ.T.t Row.t = +let rec get_type_row (row : LLTZ.E.t Row.t) : LLTZ.T.t Row.t = match row with | Row.Leaf (label_opt, expr) -> Row.Leaf (label_opt, expr.type_) | Row.Node exprs -> Row.Node (List.map ~f:(fun x -> get_type_row x) exprs) +;; -let rec get_proj_type (row: LLTZ.T.t Row.t) (path: int list) : LLTZ.T.t = +let rec get_proj_type (row : LLTZ.T.t Row.t) (path : int list) : LLTZ.T.t = match path with | i :: path -> (match row with - | Row.Leaf (_, _) -> raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)] - | Row.Node row_list -> - (match List.nth row_list i with - | Some expr -> get_proj_type expr path - | None -> raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)])) - | [] -> (match row with - | Row.Leaf (_, type_) -> type_ - | Row.Node _ -> raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)]) - -let get_inj_type (context: Type.t LLTZ.R.Context.t) : LLTZ.T.desc = + | Row.Leaf (_, _) -> + raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)] + | Row.Node row_list -> + (match List.nth row_list i with + | Some expr -> get_proj_type expr path + | None -> + raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)])) + | [] -> + (match row with + | Row.Leaf (_, type_) -> type_ + | Row.Node _ -> + raise_s [%message "Invalid path" (path : int list) (row : LLTZ.T.t Row.t)]) +;; + +let get_inj_type (context : Type.t LLTZ.R.Context.t) : LLTZ.T.desc = match context with | LLTZ.R.Context.Hole ty -> ty.desc | LLTZ.R.Context.Node (left_val, mid, right_val) -> let full = left_val @ [ mid ] @ right_val in LLTZ.T.Or (Node full) +;; -let convert_option str_opt = - Option.map ~f:(fun str -> LLTZ.R.Label str) str_opt +let convert_option str_opt = Option.map ~f:(fun str -> LLTZ.R.Label str) str_opt (* Constants *) -let unit ?(range = dummy) () = create ~range (LLTZ.E.Const(Unit)) (mk_type ~range LLTZ.T.Unit) -let bool ?(range = dummy) b = create ~range (LLTZ.E.Const(Bool b)) (mk_type ~range LLTZ.T.Bool) -let nat ?(range = dummy) n = create ~range (LLTZ.E.Const(Nat (Z.of_int n))) (mk_type ~range LLTZ.T.Nat) -let int ?(range = dummy) n = create ~range (LLTZ.E.Const(Int (Z.of_int n))) (mk_type ~range LLTZ.T.Int) -let mutez ?(range = dummy) n = create ~range (LLTZ.E.Const(Mutez (Z.of_int n))) (mk_type ~range LLTZ.T.Mutez) -let string ?(range = dummy) s = create ~range (LLTZ.E.Const(String s)) (mk_type ~range LLTZ.T.String) -let key ?(range = dummy) s = create ~range (LLTZ.E.Const(Key s)) (mk_type ~range LLTZ.T.Keys) -let key_hash ?(range = dummy) s = create ~range (LLTZ.E.Const(Key_hash s)) (mk_type ~range LLTZ.T.Key_hash) -let bytes ?(range = dummy) s = create ~range (LLTZ.E.Const(Bytes s)) (mk_type ~range LLTZ.T.Bytes) -let chain_id ?(range = dummy) s = create ~range (LLTZ.E.Const(Chain_id s)) (mk_type ~range LLTZ.T.Chain_id) -let address_const ?(range = dummy) s = create ~range (LLTZ.E.Const(Address s)) (mk_type ~range LLTZ.T.Address) -let timestamp ?(range = dummy) s = create ~range (LLTZ.E.Const(Timestamp s)) (mk_type ~range LLTZ.T.Timestamp) -let bls12_381_g1 ?(range = dummy) s = create ~range (LLTZ.E.Const(Bls12_381_g1 s)) (mk_type ~range LLTZ.T.Bls12_381_g1) -let bls12_381_g2 ?(range = dummy) s = create ~range (LLTZ.E.Const(Bls12_381_g2 s)) (mk_type ~range LLTZ.T.Bls12_381_g2) -let bls12_381_fr ?(range = dummy) s = create ~range (LLTZ.E.Const(Bls12_381_fr s)) (mk_type ~range LLTZ.T.Bls12_381_fr) -let signature ?(range = dummy) s = create ~range (LLTZ.E.Const(Signature s)) (mk_type ~range LLTZ.T.Signature) +let unit ?(range = dummy) () = + create ~range (LLTZ.E.Const Unit) (mk_type ~range LLTZ.T.Unit) +;; + +let bool ?(range = dummy) b = + create ~range (LLTZ.E.Const (Bool b)) (mk_type ~range LLTZ.T.Bool) +;; + +let nat ?(range = dummy) n = + create ~range (LLTZ.E.Const (Nat (Z.of_int n))) (mk_type ~range LLTZ.T.Nat) +;; + +let int ?(range = dummy) n = + create ~range (LLTZ.E.Const (Int (Z.of_int n))) (mk_type ~range LLTZ.T.Int) +;; + +let mutez ?(range = dummy) n = + create ~range (LLTZ.E.Const (Mutez (Z.of_int n))) (mk_type ~range LLTZ.T.Mutez) +;; + +let string ?(range = dummy) s = + create ~range (LLTZ.E.Const (String s)) (mk_type ~range LLTZ.T.String) +;; + +let key ?(range = dummy) s = + create ~range (LLTZ.E.Const (Key s)) (mk_type ~range LLTZ.T.Keys) +;; + +let key_hash ?(range = dummy) s = + create ~range (LLTZ.E.Const (Key_hash s)) (mk_type ~range LLTZ.T.Key_hash) +;; + +let bytes ?(range = dummy) s = + create ~range (LLTZ.E.Const (Bytes s)) (mk_type ~range LLTZ.T.Bytes) +;; + +let chain_id ?(range = dummy) s = + create ~range (LLTZ.E.Const (Chain_id s)) (mk_type ~range LLTZ.T.Chain_id) +;; + +let address_const ?(range = dummy) s = + create ~range (LLTZ.E.Const (Address s)) (mk_type ~range LLTZ.T.Address) +;; + +let timestamp ?(range = dummy) s = + create ~range (LLTZ.E.Const (Timestamp s)) (mk_type ~range LLTZ.T.Timestamp) +;; + +let bls12_381_g1 ?(range = dummy) s = + create ~range (LLTZ.E.Const (Bls12_381_g1 s)) (mk_type ~range LLTZ.T.Bls12_381_g1) +;; + +let bls12_381_g2 ?(range = dummy) s = + create ~range (LLTZ.E.Const (Bls12_381_g2 s)) (mk_type ~range LLTZ.T.Bls12_381_g2) +;; + +let bls12_381_fr ?(range = dummy) s = + create ~range (LLTZ.E.Const (Bls12_381_fr s)) (mk_type ~range LLTZ.T.Bls12_381_fr) +;; + +let signature ?(range = dummy) s = + create ~range (LLTZ.E.Const (Signature s)) (mk_type ~range LLTZ.T.Signature) +;; (* Variables *) let var name = LLTZ.E.Var name @@ -84,7 +137,6 @@ let address_ty ?(range = dummy) () = LLTZ.T.{ desc = Address; range } let key_ty ?(range = dummy) () = LLTZ.T.{ desc = Keys; range } let key_hash_ty ?(range = dummy) () = LLTZ.T.{ desc = Key_hash; range } let signature_ty ?(range = dummy) () = LLTZ.T.{ desc = Signature; range } - let tuple_ty ?(range = dummy) row = LLTZ.T.{ desc = Tuple row; range } let or_ty ?(range = dummy) row = LLTZ.T.{ desc = Or row; range } let option_ty ?(range = dummy) ty = LLTZ.T.{ desc = Option ty; range } @@ -95,360 +147,963 @@ let ticket_ty ?(range = dummy) ty = LLTZ.T.{ desc = Ticket ty; range } let function_ty ?(range = dummy) arg ret = LLTZ.T.{ desc = Function (arg, ret); range } let map_ty ?(range = dummy) key value = LLTZ.T.{ desc = Map (key, value); range } let big_map_ty ?(range = dummy) key value = LLTZ.T.{ desc = Big_map (key, value); range } - let mk_row row = LLTZ.R.Node row -let mk_tuple_ty ?(range = dummy) list = tuple_ty ~range (mk_row (List.map ~f:(fun x -> LLTZ.R.Leaf (None, x)) list)) +let mk_tuple_ty ?(range = dummy) list = + tuple_ty ~range (mk_row (List.map ~f:(fun x -> LLTZ.R.Leaf (None, x)) list)) +;; (* Primitives *) (* Expressions *) let variable ?(range = dummy) var var_ty = create ~range (LLTZ.E.Variable var) var_ty -let let_in ?(range = dummy) var ~rhs ~in_ = create ~range (LLTZ.E.Let_in { let_var = var; rhs; in_ }) in_.type_ -let ( let* ) rhs in_ = let xname = Name.create () in let_in (Var xname) ~rhs ~in_ -let lambda ?(range = dummy) (var,var_ty) ~body = create ~range (LLTZ.E.Lambda { lam_var = (var,var_ty); body }) (mk_type (LLTZ.T.Function (var_ty, body.type_))) -let lambda_rec ?(range = dummy) (mu_var) (var, var_ty) ~(body:LLTZ.E.t) = create ~range (Lambda_rec { mu_var = (mu_var, mk_type (LLTZ.T.Function (var_ty, body.type_)) ~range); lambda = { lam_var = (var, var_ty); body = body } }) (mk_type (LLTZ.T.Function (var_ty, body.type_))) -let app ?(range = dummy) (abs:LLTZ.E.t) arg = +let let_in ?(range = dummy) var ~rhs ~in_ = + create ~range (LLTZ.E.Let_in { let_var = var; rhs; in_ }) in_.type_ +;; + +let ( let* ) rhs in_ = + let xname = Name.create () in + let_in (Var xname) ~rhs ~in_ +;; + +let lambda ?(range = dummy) (var, var_ty) ~body = + create + ~range + (LLTZ.E.Lambda { lam_var = var, var_ty; body }) + (mk_type (LLTZ.T.Function (var_ty, body.type_))) +;; + +let lambda_rec ?(range = dummy) mu_var (var, var_ty) ~(body : LLTZ.E.t) = + create + ~range + (Lambda_rec + { mu_var = mu_var, mk_type (LLTZ.T.Function (var_ty, body.type_)) ~range + ; lambda = { lam_var = var, var_ty; body } + }) + (mk_type (LLTZ.T.Function (var_ty, body.type_))) +;; + +let app ?(range = dummy) (abs : LLTZ.E.t) arg = let ret_ty = match abs.type_.desc with | LLTZ.T.Function (_, ret_ty) -> ret_ty | _ -> raise_s [%message "Expected function type" (abs.type_ : LLTZ.T.t)] in create ~range (LLTZ.E.App { abs; arg }) ret_ty -let let_mut_in ?(range = dummy) var ~rhs ~in_ = create ~range (LLTZ.E.Let_mut_in { let_var = var; rhs; in_ }) in_.type_ +;; + +let let_mut_in ?(range = dummy) var ~rhs ~in_ = + create ~range (LLTZ.E.Let_mut_in { let_var = var; rhs; in_ }) in_.type_ +;; + let deref ?(range = dummy) var var_ty = create ~range (LLTZ.E.Deref var) var_ty -let assign ?(range = dummy) var value = create ~range (LLTZ.E.Assign (var, value)) (unit_ty ()) -let if_bool ?(range = dummy) condition ~then_ ~else_ = create ~range (LLTZ.E.If_bool { condition; if_true = then_; if_false = else_ }) then_.type_ -let if_none ?(range = dummy) subject ~none ~some = create ~range (LLTZ.E.If_none { subject; if_none = none; if_some = some }) none.type_ -let if_cons ?(range = dummy) subject ~empty ~nonempty = create ~range (LLTZ.E.If_cons { subject; if_empty = empty; if_nonempty = nonempty }) empty.type_ -let if_left ?(range = dummy) subject ~left ~right = create ~range (LLTZ.E.If_left { subject; if_left = left; if_right = right }) left.body.type_ -let while_ ?(range = dummy) cond ~body = create ~range (LLTZ.E.While { cond; body }) (unit_ty ()) -let while_left ?(range = dummy) cond ~body = create ~range (LLTZ.E.While_left { cond; body }) ( - match body.body.type_.desc with - | LLTZ.T.Or (LLTZ.R.Node [LLTZ.R.Leaf (_, left_ty); LLTZ.R.Leaf (_, right_ty)]) -> right_ty - | _ -> raise_s [%message "Expected or type" (body.body.type_ : LLTZ.T.t)] -) -let for_ ?(range = dummy) index ~init ~cond ~update ~body = create ~range (LLTZ.E.For { index; init; cond; update; body }) body.type_ -let for_each ?(range = dummy) collection ~body = create ~range (LLTZ.E.For_each { collection; body }) (unit_ty ()) -let map ?(range = dummy) collection ~map = create ~range (LLTZ.E.Map { collection; map }) ( - match collection.type_.desc with - | LLTZ.T.List ty1 -> mk_type (LLTZ.T.List map.body.type_) ~range - | LLTZ.T.Option ty1 -> mk_type (LLTZ.T.Option map.body.type_) ~range - | LLTZ.T.Map (kty, ty1) -> mk_type (LLTZ.T.Map (kty, map.body.type_)) ~range - | _ -> raise_s [%message "Expected list, option, or map type" (collection.desc: LLTZ.E.desc) (collection.type_ : LLTZ.T.t)] -) -let fold_left ?(range = dummy) collection ~init ~fold = create ~range (LLTZ.E.Fold_left { collection; init; fold }) fold.body.type_ -let fold_right ?(range = dummy) collection ~init ~fold = create ~range (LLTZ.E.Fold_right { collection; init; fold }) fold.body.type_ -let let_tuple_in ?(range = dummy) components ~rhs ~in_ = create ~range (LLTZ.E.Let_tuple_in { components; rhs; in_ }) in_.type_ -let tuple ?(range = dummy) row = create ~range (LLTZ.E.Tuple row) (mk_type (LLTZ.T.Tuple (get_type_row row)) ~range) -let proj ?(range = dummy) tuple ~path = create ~range (LLTZ.E.Proj (tuple, path)) ( - match tuple, path with - | LLTZ.E.{ type_ = { desc = Tuple tuple_row; _ }; _ }, Here path_list -> get_proj_type tuple_row path_list - | _ -> raise_s [%message "Expected tuple type" (tuple : LLTZ.E.t)]) -let update_tuple ?(range = dummy) tuple ~component ~update = create ~range (LLTZ.E.Update { tuple; component; update }) tuple.type_ -let inj ?(range = dummy) context expr = create ~range (LLTZ.E.Inj (context, expr)) (mk_type (get_inj_type context) ~range) -let match_ ?(range = dummy) subject ~cases = create ~range (LLTZ.E.Match (subject, cases)) ( - match LLTZ.R.find_leaf cases with - | Some leaf -> ( - match leaf with - | {lam_var = _; body} -> body.type_ - ) - | None -> raise_s [%message "Expected a leaf with lambda" (cases : LLTZ.E.lambda_typed LLTZ.R.t)] - ) -let raw_michelson ?(range = dummy) michelson args return_ty = create ~range (LLTZ.E.Raw_michelson {michelson; args}) return_ty -let create_contract ?(range = dummy) () ~storage ~code ~delegate ~initial_balance ~initial_storage = - create ~range (LLTZ.E.Create_contract { storage; code; delegate; initial_balance; initial_storage }) (mk_type ~range (LLTZ.T.Tuple (Row.Node [Row.Leaf (None, mk_type ~range LLTZ.T.Address); Row.Leaf (None,mk_type ~range LLTZ.T.Operation)]))) + +let assign ?(range = dummy) var value = + create ~range (LLTZ.E.Assign (var, value)) (unit_ty ()) +;; + +let if_bool ?(range = dummy) condition ~then_ ~else_ = + create + ~range + (LLTZ.E.If_bool { condition; if_true = then_; if_false = else_ }) + then_.type_ +;; + +let if_none ?(range = dummy) subject ~none ~some = + create ~range (LLTZ.E.If_none { subject; if_none = none; if_some = some }) none.type_ +;; + +let if_cons ?(range = dummy) subject ~empty ~nonempty = + create + ~range + (LLTZ.E.If_cons { subject; if_empty = empty; if_nonempty = nonempty }) + empty.type_ +;; + +let if_left ?(range = dummy) subject ~left ~right = + create + ~range + (LLTZ.E.If_left { subject; if_left = left; if_right = right }) + left.body.type_ +;; + +let while_ ?(range = dummy) cond ~body = + create ~range (LLTZ.E.While { cond; body }) (unit_ty ()) +;; + +let while_left ?(range = dummy) cond ~body = + create + ~range + (LLTZ.E.While_left { cond; body }) + (match body.body.type_.desc with + | LLTZ.T.Or (LLTZ.R.Node [ LLTZ.R.Leaf (_, left_ty); LLTZ.R.Leaf (_, right_ty) ]) -> + right_ty + | _ -> raise_s [%message "Expected or type" (body.body.type_ : LLTZ.T.t)]) +;; + +let for_ ?(range = dummy) index ~init ~cond ~update ~body = + create ~range (LLTZ.E.For { index; init; cond; update; body }) body.type_ +;; + +let for_each ?(range = dummy) collection ~body = + create ~range (LLTZ.E.For_each { collection; body }) (unit_ty ()) +;; + +let map ?(range = dummy) collection ~map = + create + ~range + (LLTZ.E.Map { collection; map }) + (match collection.type_.desc with + | LLTZ.T.List ty1 -> mk_type (LLTZ.T.List map.body.type_) ~range + | LLTZ.T.Option ty1 -> mk_type (LLTZ.T.Option map.body.type_) ~range + | LLTZ.T.Map (kty, ty1) -> mk_type (LLTZ.T.Map (kty, map.body.type_)) ~range + | _ -> + raise_s + [%message + "Expected list, option, or map type" + (collection.desc : LLTZ.E.desc) + (collection.type_ : LLTZ.T.t)]) +;; + +let fold_left ?(range = dummy) collection ~init ~fold = + create ~range (LLTZ.E.Fold_left { collection; init; fold }) fold.body.type_ +;; + +let fold_right ?(range = dummy) collection ~init ~fold = + create ~range (LLTZ.E.Fold_right { collection; init; fold }) fold.body.type_ +;; + +let let_tuple_in ?(range = dummy) components ~rhs ~in_ = + create ~range (LLTZ.E.Let_tuple_in { components; rhs; in_ }) in_.type_ +;; + +let tuple ?(range = dummy) row = + create ~range (LLTZ.E.Tuple row) (mk_type (LLTZ.T.Tuple (get_type_row row)) ~range) +;; + +let proj ?(range = dummy) tuple ~path = + create + ~range + (LLTZ.E.Proj (tuple, path)) + (match tuple, path with + | LLTZ.E.{ type_ = { desc = Tuple tuple_row; _ }; _ }, Here path_list -> + get_proj_type tuple_row path_list + | _ -> raise_s [%message "Expected tuple type" (tuple : LLTZ.E.t)]) +;; + +let update_tuple ?(range = dummy) tuple ~component ~update = + create ~range (LLTZ.E.Update { tuple; component; update }) tuple.type_ +;; + +let inj ?(range = dummy) context expr = + create ~range (LLTZ.E.Inj (context, expr)) (mk_type (get_inj_type context) ~range) +;; + +let match_ ?(range = dummy) subject ~cases = + create + ~range + (LLTZ.E.Match (subject, cases)) + (match LLTZ.R.find_leaf cases with + | Some leaf -> + (match leaf with + | { lam_var = _; body } -> body.type_) + | None -> + raise_s + [%message "Expected a leaf with lambda" (cases : LLTZ.E.lambda_typed LLTZ.R.t)]) +;; + +let raw_michelson ?(range = dummy) michelson args return_ty = + create ~range (LLTZ.E.Raw_michelson { michelson; args }) return_ty +;; + +let create_contract + ?(range = dummy) + () + ~storage + ~code + ~delegate + ~initial_balance + ~initial_storage + = + create + ~range + (LLTZ.E.Create_contract { storage; code; delegate; initial_balance; initial_storage }) + (mk_type + ~range + (LLTZ.T.Tuple + (Row.Node + [ Row.Leaf (None, mk_type ~range LLTZ.T.Address) + ; Row.Leaf (None, mk_type ~range LLTZ.T.Operation) + ]))) +;; (* Primitives *) (* Arity 0 *) -let amount ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Amount, [])) (mk_type ~range LLTZ.T.Mutez) -let balance ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Balance, [])) (mk_type ~range LLTZ.T.Mutez) -let chain_id_prim ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Chain_id, [])) (mk_type ~range LLTZ.T.Chain_id) -let level ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Level, [])) (mk_type ~range LLTZ.T.Nat) -let now ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Now, [])) (mk_type ~range LLTZ.T.Timestamp) -let self ?(range = dummy) str_opt contract_ty = create ~range (LLTZ.E.Prim (LLTZ.P.Self str_opt, [])) contract_ty -let self_address ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Self_address, [])) (mk_type ~range LLTZ.T.Address) -let sender ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Sender, [])) (mk_type ~range LLTZ.T.Address) -let source ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Source, [])) (mk_type ~range LLTZ.T.Address) -let total_voting_power ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Total_voting_power, [])) (mk_type ~range LLTZ.T.Nat) -let empty_bigmap ?(range = dummy) key value = create ~range (LLTZ.E.Prim (LLTZ.P.Empty_bigmap (key, value), [])) (mk_type ~range (LLTZ.T.Big_map (key, value))) -let empty_map ?(range = dummy) key value = create ~range (LLTZ.E.Prim (LLTZ.P.Empty_map (key, value), [])) (mk_type ~range (LLTZ.T.Map (key, value))) -let empty_set ?(range = dummy) ty = create ~range (LLTZ.E.Prim (LLTZ.P.Empty_set ty, [])) (mk_type ~range (LLTZ.T.Set ty)) -let nil ?(range = dummy) ty = create ~range (LLTZ.E.Prim (LLTZ.P.Nil ty, [])) (mk_type ~range (LLTZ.T.List ty)) -let none ?(range = dummy) ty = create ~range (LLTZ.E.Prim (LLTZ.P.None ty, [])) (mk_type ~range (LLTZ.T.Option ty)) -let sapling_empty_state ?(range = dummy) memo = create ~range (LLTZ.E.Prim (LLTZ.P.Sapling_empty_state { memo }, [])) (mk_type ~range (LLTZ.T.Sapling_state { memo })) -let unit_prim ?(range = dummy) () = create ~range (LLTZ.E.Prim (LLTZ.P.Unit, [])) (mk_type ~range LLTZ.T.Unit) +let amount ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Amount, [])) (mk_type ~range LLTZ.T.Mutez) +;; + +let balance ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Balance, [])) (mk_type ~range LLTZ.T.Mutez) +;; + +let chain_id_prim ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Chain_id, [])) (mk_type ~range LLTZ.T.Chain_id) +;; + +let level ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Level, [])) (mk_type ~range LLTZ.T.Nat) +;; + +let now ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Now, [])) (mk_type ~range LLTZ.T.Timestamp) +;; + +let self ?(range = dummy) str_opt contract_ty = + create ~range (LLTZ.E.Prim (LLTZ.P.Self str_opt, [])) contract_ty +;; + +let self_address ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Self_address, [])) (mk_type ~range LLTZ.T.Address) +;; + +let sender ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Sender, [])) (mk_type ~range LLTZ.T.Address) +;; + +let source ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Source, [])) (mk_type ~range LLTZ.T.Address) +;; + +let total_voting_power ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Total_voting_power, [])) (mk_type ~range LLTZ.T.Nat) +;; + +let empty_bigmap ?(range = dummy) key value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Empty_bigmap (key, value), [])) + (mk_type ~range (LLTZ.T.Big_map (key, value))) +;; + +let empty_map ?(range = dummy) key value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Empty_map (key, value), [])) + (mk_type ~range (LLTZ.T.Map (key, value))) +;; + +let empty_set ?(range = dummy) ty = + create ~range (LLTZ.E.Prim (LLTZ.P.Empty_set ty, [])) (mk_type ~range (LLTZ.T.Set ty)) +;; + +let nil ?(range = dummy) ty = + create ~range (LLTZ.E.Prim (LLTZ.P.Nil ty, [])) (mk_type ~range (LLTZ.T.List ty)) +;; + +let none ?(range = dummy) ty = + create ~range (LLTZ.E.Prim (LLTZ.P.None ty, [])) (mk_type ~range (LLTZ.T.Option ty)) +;; + +let sapling_empty_state ?(range = dummy) memo = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Sapling_empty_state { memo }, [])) + (mk_type ~range (LLTZ.T.Sapling_state { memo })) +;; + +let unit_prim ?(range = dummy) () = + create ~range (LLTZ.E.Prim (LLTZ.P.Unit, [])) (mk_type ~range LLTZ.T.Unit) +;; (* Arity 1/2 *) -let car ?(range = dummy) pair = create ~range (LLTZ.E.Prim (LLTZ.P.Car, [pair])) ( - match pair.type_.desc with - | LLTZ.T.Tuple (Node (Leaf(_,hd)::_)) -> hd - | _ -> raise_s [%message "Expected pair type" (pair.type_ : LLTZ.T.t)]) -let cdr ?(range = dummy) pair = create ~range (LLTZ.E.Prim (LLTZ.P.Cdr, [pair])) ( - match pair.type_.desc with - | LLTZ.T.Tuple (Node (Leaf(_,_)::Leaf(_,tl)::[])) -> tl - | _ -> raise_s [%message "Expected pair type" (pair.type_ : LLTZ.T.t)]) -let left ?(range = dummy) (opt1, opt2, ty) value = create ~range (LLTZ.E.Prim (LLTZ.P.Left (opt1, opt2, ty), [value])) (mk_type ~range (LLTZ.T.Or (LLTZ.R.Node [LLTZ.R.Leaf (convert_option opt1, value.type_); LLTZ.R.Leaf (convert_option opt2, ty)]))) -let right ?(range = dummy) (opt1, opt2, ty) value = create ~range (LLTZ.E.Prim (LLTZ.P.Right (opt1, opt2, ty), [value])) (mk_type ~range (LLTZ.T.Or (LLTZ.R.Node [LLTZ.R.Leaf (convert_option opt1, ty); LLTZ.R.Leaf (convert_option opt2, value.type_)]))) -let some ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Some, [value])) (mk_type ~range (LLTZ.T.Option value.type_)) -let abs ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Abs, [value])) (mk_type ~range LLTZ.T.Nat) -let neg ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Neg, [value])) (mk_type ~range - ( - let open LLTZ.T in - match value.type_.desc with - | Int - | Nat -> Int - | Bls12_381_g1 - | Bls12_381_g2 - | Bls12_381_fr -> value.type_.desc (* Return the same type *) - | _ -> raise_s [%message "Expected int,nat or BLS12-381 field/group element type" (value.type_ : t)] - ) -) -let nat_prim ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Nat, [value])) (mk_type ~range LLTZ.T.Nat) -let int_prim ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Int, [value])) (mk_type ~range LLTZ.T.Int) -let bytes_prim ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Bytes, [value])) (mk_type ~range LLTZ.T.Bytes) -let is_nat ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Is_nat, [value])) (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Nat))) +let car ?(range = dummy) pair = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Car, [ pair ])) + (match pair.type_.desc with + | LLTZ.T.Tuple (Node (Leaf (_, hd) :: _)) -> hd + | _ -> raise_s [%message "Expected pair type" (pair.type_ : LLTZ.T.t)]) +;; + +let cdr ?(range = dummy) pair = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Cdr, [ pair ])) + (match pair.type_.desc with + | LLTZ.T.Tuple (Node [ Leaf (_, _); Leaf (_, tl) ]) -> tl + | _ -> raise_s [%message "Expected pair type" (pair.type_ : LLTZ.T.t)]) +;; + +let left ?(range = dummy) (opt1, opt2, ty) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Left (opt1, opt2, ty), [ value ])) + (mk_type + ~range + (LLTZ.T.Or + (LLTZ.R.Node + [ LLTZ.R.Leaf (convert_option opt1, value.type_) + ; LLTZ.R.Leaf (convert_option opt2, ty) + ]))) +;; + +let right ?(range = dummy) (opt1, opt2, ty) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Right (opt1, opt2, ty), [ value ])) + (mk_type + ~range + (LLTZ.T.Or + (LLTZ.R.Node + [ LLTZ.R.Leaf (convert_option opt1, ty) + ; LLTZ.R.Leaf (convert_option opt2, value.type_) + ]))) +;; + +let some ?(range = dummy) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Some, [ value ])) + (mk_type ~range (LLTZ.T.Option value.type_)) +;; + +let abs ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Abs, [ value ])) (mk_type ~range LLTZ.T.Nat) +;; + +let neg ?(range = dummy) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Neg, [ value ])) + (mk_type + ~range + (let open LLTZ.T in + match value.type_.desc with + | Int | Nat -> Int + | Bls12_381_g1 | Bls12_381_g2 | Bls12_381_fr -> + value.type_.desc (* Return the same type *) + | _ -> + raise_s + [%message + "Expected int,nat or BLS12-381 field/group element type" (value.type_ : t)])) +;; + +let nat_prim ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Nat, [ value ])) (mk_type ~range LLTZ.T.Nat) +;; + +let int_prim ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Int, [ value ])) (mk_type ~range LLTZ.T.Int) +;; + +let bytes_prim ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Bytes, [ value ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let is_nat ?(range = dummy) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Is_nat, [ value ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Nat))) +;; (* comparisons modified to have arity 2 *) -let compare_ ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Compare, [lhs; rhs])) (mk_type ~range LLTZ.T.Int) -let eq ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Eq, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) -let neq ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Neq, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) -let le ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Le, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) -let lt ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Lt, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) -let ge ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Ge, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) -let gt ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Gt, [compare_ ~range lhs rhs])) (mk_type ~range LLTZ.T.Bool) - -let not ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Not, [value])) (mk_type ~range - ( - let open LLTZ.T in - match value.type_.desc with - | Bool -> Bool - | Nat -> Int - | Int -> Int - | Bytes -> Bytes - | _ -> raise_s [%message "Expected bool, nat, int, or bytes type" (value.type_ : t)] - ) -) -let size ?(range = dummy) container = create ~range (LLTZ.E.Prim (LLTZ.P.Size, [container])) (mk_type ~range LLTZ.T.Nat) -let address ?(range = dummy) contract = create ~range (LLTZ.E.Prim (LLTZ.P.Address, [contract])) (mk_type ~range LLTZ.T.Address) -let implicit_account ?(range = dummy) key_hash = create ~range (LLTZ.E.Prim (LLTZ.P.Implicit_account, [key_hash])) (mk_type ~range (LLTZ.T.Contract (mk_type ~range LLTZ.T.Unit))) -let contract ?(range = dummy) (opt, ty) address = create ~range (LLTZ.E.Prim (LLTZ.P.Contract (opt, ty), [address])) (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Contract ty)))) -let pack ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Pack, [value])) (mk_type ~range LLTZ.T.Bytes) -let unpack ?(range = dummy) ty value = create ~range (LLTZ.E.Prim (LLTZ.P.Unpack ty, [value])) (mk_type ~range (LLTZ.T.Option ty)) -let hash_key ?(range = dummy) key = create ~range (LLTZ.E.Prim (LLTZ.P.Hash_key, [key])) (mk_type ~range LLTZ.T.Key_hash) -let blake2b ?(range = dummy) bytes = create ~range (LLTZ.E.Prim (LLTZ.P.Blake2b, [bytes])) (mk_type ~range LLTZ.T.Bytes) -let sha256 ?(range = dummy) bytes = create ~range (LLTZ.E.Prim (LLTZ.P.Sha256, [bytes])) (mk_type ~range LLTZ.T.Bytes) -let sha512 ?(range = dummy) bytes = create ~range (LLTZ.E.Prim (LLTZ.P.Sha512, [bytes])) (mk_type ~range LLTZ.T.Bytes) -let keccak ?(range = dummy) bytes = create ~range (LLTZ.E.Prim (LLTZ.P.Keccak, [bytes])) (mk_type ~range LLTZ.T.Bytes) -let sha3 ?(range = dummy) bytes = create ~range (LLTZ.E.Prim (LLTZ.P.Sha3, [bytes])) (mk_type ~range LLTZ.T.Bytes) -let set_delegate ?(range = dummy) delegate = create ~range (LLTZ.E.Prim (LLTZ.P.Set_delegate, [delegate])) (mk_type ~range LLTZ.T.Operation) -let read_ticket ?(range = dummy) ticket = create ~range (LLTZ.E.Prim (LLTZ.P.Read_ticket, [ticket])) - (mk_type ~range - (match ticket.type_.desc with - | LLTZ.T.Ticket cty -> - LLTZ.T.Tuple (LLTZ.R.Node [ - LLTZ.R.Leaf (None,mk_type ~range LLTZ.T.Address); (* Address part of the ticket *) - LLTZ.R.Leaf (None,cty); (* The content type of the ticket *) - LLTZ.R.Leaf (None, mk_type ~range LLTZ.T.Nat); (* The amount (Nat) part of the ticket *) - LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket cty)) (* The original ticket type *) - ]) - | _ -> raise_s [%message "Expected ticket type" (ticket.type_ : LLTZ.T.t)] - ) - ) -let join_tickets ?(range = dummy) ticket1 ticket2 = create ~range (LLTZ.E.Prim (LLTZ.P.Join_tickets, [ticket1; ticket2])) - (mk_type ~range - (match (ticket1.type_.desc, ticket2.type_.desc) with - | (LLTZ.T.Ticket cty1, LLTZ.T.Ticket _) -> - LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket cty1)) - | _ -> raise_s [%message "Expected two tickets of the same type" - (ticket1.type_ : LLTZ.T.t) - (ticket2.type_ : LLTZ.T.t)] - ) - ) -let pairing_check ?(range = dummy) pairings = create ~range (LLTZ.E.Prim (LLTZ.P.Pairing_check, [pairings])) (mk_type ~range LLTZ.T.Bool) -let voting_power ?(range = dummy) key_hash = create ~range (LLTZ.E.Prim (LLTZ.P.Voting_power, [key_hash])) (mk_type ~range LLTZ.T.Nat) -let getn ?(range = dummy) n value = create ~range (LLTZ.E.Prim (LLTZ.P.Get_n n, [value])) (assert false) (*TODO*) -let cast ?(range = dummy) ty value = create ~range (LLTZ.E.Prim (LLTZ.P.Cast ty, [value])) ty +let compare_ ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.Compare, [ lhs; rhs ])) (mk_type ~range LLTZ.T.Int) +;; + +let eq ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Eq, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let neq ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Neq, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let le ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Le, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let lt ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Lt, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let ge ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Ge, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let gt ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Gt, [ compare_ ~range lhs rhs ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let not ?(range = dummy) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Not, [ value ])) + (mk_type + ~range + (let open LLTZ.T in + match value.type_.desc with + | Bool -> Bool + | Nat -> Int + | Int -> Int + | Bytes -> Bytes + | _ -> + raise_s [%message "Expected bool, nat, int, or bytes type" (value.type_ : t)])) +;; + +let size ?(range = dummy) container = + create ~range (LLTZ.E.Prim (LLTZ.P.Size, [ container ])) (mk_type ~range LLTZ.T.Nat) +;; + +let address ?(range = dummy) contract = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Address, [ contract ])) + (mk_type ~range LLTZ.T.Address) +;; + +let implicit_account ?(range = dummy) key_hash = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Implicit_account, [ key_hash ])) + (mk_type ~range (LLTZ.T.Contract (mk_type ~range LLTZ.T.Unit))) +;; + +let contract ?(range = dummy) (opt, ty) address = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Contract (opt, ty), [ address ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Contract ty)))) +;; + +let pack ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Pack, [ value ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let unpack ?(range = dummy) ty value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Unpack ty, [ value ])) + (mk_type ~range (LLTZ.T.Option ty)) +;; + +let hash_key ?(range = dummy) key = + create ~range (LLTZ.E.Prim (LLTZ.P.Hash_key, [ key ])) (mk_type ~range LLTZ.T.Key_hash) +;; + +let blake2b ?(range = dummy) bytes = + create ~range (LLTZ.E.Prim (LLTZ.P.Blake2b, [ bytes ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let sha256 ?(range = dummy) bytes = + create ~range (LLTZ.E.Prim (LLTZ.P.Sha256, [ bytes ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let sha512 ?(range = dummy) bytes = + create ~range (LLTZ.E.Prim (LLTZ.P.Sha512, [ bytes ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let keccak ?(range = dummy) bytes = + create ~range (LLTZ.E.Prim (LLTZ.P.Keccak, [ bytes ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let sha3 ?(range = dummy) bytes = + create ~range (LLTZ.E.Prim (LLTZ.P.Sha3, [ bytes ])) (mk_type ~range LLTZ.T.Bytes) +;; + +let set_delegate ?(range = dummy) delegate = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Set_delegate, [ delegate ])) + (mk_type ~range LLTZ.T.Operation) +;; + +let read_ticket ?(range = dummy) ticket = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Read_ticket, [ ticket ])) + (mk_type + ~range + (match ticket.type_.desc with + | LLTZ.T.Ticket cty -> + LLTZ.T.Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range LLTZ.T.Address) + ; (* Address part of the ticket *) + LLTZ.R.Leaf (None, cty) + ; (* The content type of the ticket *) + LLTZ.R.Leaf (None, mk_type ~range LLTZ.T.Nat) + ; (* The amount (Nat) part of the ticket *) + LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket cty)) + (* The original ticket type *) + ]) + | _ -> raise_s [%message "Expected ticket type" (ticket.type_ : LLTZ.T.t)])) +;; + +let join_tickets ?(range = dummy) ticket1 ticket2 = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Join_tickets, [ ticket1; ticket2 ])) + (mk_type + ~range + (match ticket1.type_.desc, ticket2.type_.desc with + | LLTZ.T.Ticket cty1, LLTZ.T.Ticket _ -> + LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket cty1)) + | _ -> + raise_s + [%message + "Expected two tickets of the same type" + (ticket1.type_ : LLTZ.T.t) + (ticket2.type_ : LLTZ.T.t)])) +;; + +let pairing_check ?(range = dummy) pairings = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Pairing_check, [ pairings ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let voting_power ?(range = dummy) key_hash = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Voting_power, [ key_hash ])) + (mk_type ~range LLTZ.T.Nat) +;; + +let getn ?(range = dummy) n value = + create ~range (LLTZ.E.Prim (LLTZ.P.Get_n n, [ value ])) (assert false) +;; + +(*TODO*) + +let cast ?(range = dummy) ty value = + create ~range (LLTZ.E.Prim (LLTZ.P.Cast ty, [ value ])) ty +;; + (*let rename = assert false*) -let emit ?(range = dummy) (opt, ty) value = create ~range (LLTZ.E.Prim (LLTZ.P.Emit (opt, ty), [value])) (mk_type ~range LLTZ.T.Operation) -let failwith ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Failwith, [value])) (mk_type ~range LLTZ.T.Unit) (*output type useless*) -let never ?(range = dummy) value = create ~range (LLTZ.E.Prim (LLTZ.P.Never, [value])) (mk_type ~range LLTZ.T.Unit) (*output type useless*) -let pair ?(range = dummy) (opt1, opt2) first second = create ~range (LLTZ.E.Prim (LLTZ.P.Pair (opt1, opt2), [first; second])) (mk_type ~range (LLTZ.T.Tuple (LLTZ.R.Node [LLTZ.R.Leaf (convert_option opt1, first.type_); LLTZ.R.Leaf (convert_option opt2, second.type_)]))) -let add ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Add, [lhs; rhs])) - ( - let open LLTZ.T in - mk_type ~range - (match (lhs.type_.desc, rhs.type_.desc) with - | (Nat, Nat) -> Nat - | (Nat, Int) -> Int - | (Int, Nat) -> Int - | (Int, Int) -> Int - | (Timestamp, Int) -> Timestamp - | (Int, Timestamp) -> Timestamp - | (Mutez, Mutez) -> Mutez - | (Bls12_381_g1, Bls12_381_g1) -> Bls12_381_g1 - | (Bls12_381_g2, Bls12_381_g2) -> Bls12_381_g2 - | (Bls12_381_fr, Bls12_381_fr) -> Bls12_381_fr - | _ -> raise_s [%message "Expected matching types for ADD operation" - (lhs.type_ : t) - (rhs.type_ : t)] - ) - ) -let mul ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Mul, [lhs; rhs])) - ( - let open LLTZ.T in - mk_type ~range - (match (lhs.type_.desc, rhs.type_.desc) with - | (Nat, Nat) -> Nat - | (Nat, Int) -> Int - | (Int, Nat) -> Int - | (Int, Int) -> Int - | (Mutez, Nat) -> Mutez - | (Nat, Mutez) -> Mutez - | (Bls12_381_g1, Bls12_381_fr) -> Bls12_381_g1 - | (Bls12_381_g2, Bls12_381_fr) -> Bls12_381_g2 - | (Bls12_381_fr, Bls12_381_fr) -> Bls12_381_fr - | (Nat, Bls12_381_fr) -> Bls12_381_fr - | (Int, Bls12_381_fr) -> Bls12_381_fr - | (Bls12_381_fr, Nat) -> Bls12_381_fr - | (Bls12_381_fr, Int) -> Bls12_381_fr - | _ -> raise_s [%message "Expected matching types for MUL operation" - (lhs.type_ : t) - (rhs.type_ : t)] - ) - ) - -let sub ?(range = dummy) (lhs:Expr.t) (rhs:Expr.t) = - match (lhs.type_.desc, rhs.type_.desc) with - | (LLTZ.T.Mutez, LLTZ.T.Mutez) -> ( - (create ~range (LLTZ.E.Prim (LLTZ.P.Sub_mutez, [lhs; rhs])) (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Mutez)))) - ) - | _ -> - create ~range (LLTZ.E.Prim (LLTZ.P.Sub, [lhs; rhs])) - ( - let open LLTZ.T in - mk_type ~range - (match (lhs.type_.desc, rhs.type_.desc) with - | (Nat, Nat) -> Int - | (Nat, Int) -> Int - | (Int, Nat) -> Int - | (Int, Int) -> Int - | (Timestamp, Int) -> Timestamp - | (Timestamp, Timestamp) -> Int - | _ -> raise_s [%message "Expected matching types for SUB operation" - (lhs.type_ : t) - (rhs.type_ : t)] - ) - ) - -let sub_mutez ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Sub_mutez, [lhs; rhs])) (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Mutez))) -let lsr_ ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Lsr, [lhs; rhs])) lhs.type_ -let lsl_ ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Lsl, [lhs; rhs])) lhs.type_ -let xor ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Xor, [lhs; rhs])) lhs.type_ -let ediv ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Ediv, [lhs; rhs])) - ( - let open LLTZ.T in - mk_type ~range - ( - match (lhs.type_.desc, rhs.type_.desc) with - | (Nat, Nat) -> Option (mk_type ~range (Tuple (LLTZ.R.Node [LLTZ.R.Leaf (None,mk_type ~range Nat);LLTZ.R.Leaf (None,mk_type ~range Nat)]))) - | (Nat, Int) - | (Int, Nat) - | (Int, Int) -> Option (mk_type ~range (Tuple (LLTZ.R.Node [LLTZ.R.Leaf (None,mk_type ~range Int);LLTZ.R.Leaf (None,mk_type ~range Nat)]))) - | (Mutez, Nat) -> Option (mk_type ~range (Tuple (LLTZ.R.Node [LLTZ.R.Leaf (None, mk_type ~range Mutez);LLTZ.R.Leaf (None, mk_type ~range Mutez)]))) - | (Mutez, Mutez) -> Option (mk_type ~range (Tuple (LLTZ.R.Node [LLTZ.R.Leaf (None, mk_type ~range Nat);LLTZ.R.Leaf (None, mk_type ~range Mutez)]))) - | _ -> raise_s [%message "Expected matching types for EDIV operation" - (lhs.type_ : t) - (rhs.type_ : t)] - ) - ) - -let div_ ?(range = dummy) (lhs:Expr.t) (rhs:Expr.t) = - (if_none ~range (ediv ~range lhs rhs) ~some:( - let var_ty = tuple_ty ~range (Row.Node [Row.Leaf (None, lhs.type_); Row.Leaf(None, rhs.type_)]) in - let var_name = Name.create () in - {lam_var=Var var_name; - body = car (variable ~range (Var var_name) (var_ty ))}) - ~none:(failwith ~range (string ~range "DIV by 0"))) - -let mod_ ?(range = dummy) (lhs:Expr.t) (rhs:Expr.t) = - (if_none ~range (ediv ~range lhs rhs) ~some:( - let var_ty = tuple_ty ~range (Row.Node [Row.Leaf (None, lhs.type_); Row.Leaf(None, rhs.type_)]) in - let var_name = Name.create () in - {lam_var=Var var_name; - body = cdr (variable ~range (Var var_name) (var_ty ))}) - ~none:(failwith ~range (string ~range "MOD by 0"))) - -let and_ ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.And, [lhs; rhs])) rhs.type_ -let or_ ?(range = dummy) lhs rhs = create ~range (LLTZ.E.Prim (LLTZ.P.Or, [lhs; rhs])) lhs.type_ -let cons ?(range = dummy) head tail = create ~range (LLTZ.E.Prim (LLTZ.P.Cons, [head; tail])) tail.type_ -let concat1 ?(range = dummy) val1 str2 = create ~range (LLTZ.E.Prim (LLTZ.P.Concat1, [val1; str2])) (mk_type ~range LLTZ.T.String) -let concat2 ?(range = dummy) val1 bytes2 = create ~range (LLTZ.E.Prim (LLTZ.P.Concat2, [val1; bytes2])) (mk_type ~range LLTZ.T.Bytes) -let get ?(range = dummy) key collection = create ~range (LLTZ.E.Prim (LLTZ.P.Get, [key; collection])) - (mk_type ~range - (match collection.type_.desc with - | LLTZ.T.Map (_, vty) - | LLTZ.T.Big_map (_, vty) -> LLTZ.T.Option vty - | _ -> raise_s [%message "Expected a map or big_map with matching key type" - (key.type_ : LLTZ.T.t) - (collection.type_ : LLTZ.T.t)] - ) - ) -let mem ?(range = dummy) key collection = create ~range (LLTZ.E.Prim (LLTZ.P.Mem, [key; collection])) (mk_type ~range LLTZ.T.Bool) -let exec ?(range = dummy) value lambda = create ~range (LLTZ.E.Prim (LLTZ.P.Exec, [value; lambda])) ( - match lambda.type_.desc with - |LLTZ.T.Function (_, ret_ty) -> ret_ty - | _ -> raise_s [%message "Expected function type" (lambda.type_ : LLTZ.T.t)]) -let apply ?(range = dummy) value lambda= create ~range (LLTZ.E.Prim (LLTZ.P.Apply, [value; lambda])) - (match lambda.type_.desc with - | LLTZ.T.Function ({ desc = LLTZ.T.Tuple ( - LLTZ.R.Node [ - LLTZ.R.Leaf (None, _); - LLTZ.R.Leaf (None, ty2) - ] - ); range = _ }, ty3) -> (mk_type ~range (LLTZ.T.Function (ty2,ty3))) - | _ -> raise_s [%message "Expected function type" (lambda.type_ : LLTZ.T.t)]) -let sapling_verify_update ?(range = dummy) transaction state = create ~range (LLTZ.E.Prim (LLTZ.P.Sapling_verify_update, [transaction; state])) - ( - let open LLTZ.T in - match (transaction.type_.desc, state.type_.desc) with - | (Sapling_transaction _, Sapling_state ms2) -> - mk_type ~range (Option ( - mk_type ~range (Tuple (LLTZ.R.Node [ - LLTZ.R.Leaf (None, mk_type ~range Bytes); - LLTZ.R.Leaf (None, mk_type ~range Int); - LLTZ.R.Leaf (None, mk_type ~range (Sapling_state ms2)) - ] - )) - ) - ) - | _ -> raise_s [%message "Expected matching sapling_transaction and sapling_state types" - (transaction.type_ : LLTZ.T.t) - (state.type_ : LLTZ.T.t)] -) -let ticket ?(range = dummy) content amount = create ~range (LLTZ.E.Prim (LLTZ.P.Ticket, [content; amount])) (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket content.type_)))) -let ticket_deprecated ?(range = dummy) content amount = create ~range (LLTZ.E.Prim (LLTZ.P.Ticket_deprecated, [content; amount])) (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket content.type_)))) -let split_ticket ?(range = dummy) ticket amounts = create ~range (LLTZ.E.Prim (LLTZ.P.Split_ticket, [ticket; amounts])) - (mk_type ~range - (LLTZ.T.Option (mk_type ~range (LLTZ.T.Tuple (LLTZ.R.Node [ - LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket ticket.type_)); - LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket ticket.type_)) - ]))))) -let updaten ?(range = dummy) n value pair = create ~range (LLTZ.E.Prim (LLTZ.P.Update_n n, [value; pair])) (assert false) (*TODO*) -let view ?(range = dummy) name ~return_type ~d ~address = create ~range (LLTZ.E.Prim (LLTZ.P.View (name, return_type), [d; address])) (mk_type ~range (LLTZ.T.Option return_type)) +let emit ?(range = dummy) (opt, ty) value = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Emit (opt, ty), [ value ])) + (mk_type ~range LLTZ.T.Operation) +;; + +let failwith ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Failwith, [ value ])) (mk_type ~range LLTZ.T.Unit) +;; + +(*output type useless*) + +let never ?(range = dummy) value = + create ~range (LLTZ.E.Prim (LLTZ.P.Never, [ value ])) (mk_type ~range LLTZ.T.Unit) +;; + +(*output type useless*) + +let pair ?(range = dummy) (opt1, opt2) first second = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Pair (opt1, opt2), [ first; second ])) + (mk_type + ~range + (LLTZ.T.Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (convert_option opt1, first.type_) + ; LLTZ.R.Leaf (convert_option opt2, second.type_) + ]))) +;; + +let add ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Add, [ lhs; rhs ])) + (let open LLTZ.T in + mk_type + ~range + (match lhs.type_.desc, rhs.type_.desc with + | Nat, Nat -> Nat + | Nat, Int -> Int + | Int, Nat -> Int + | Int, Int -> Int + | Timestamp, Int -> Timestamp + | Int, Timestamp -> Timestamp + | Mutez, Mutez -> Mutez + | Bls12_381_g1, Bls12_381_g1 -> Bls12_381_g1 + | Bls12_381_g2, Bls12_381_g2 -> Bls12_381_g2 + | Bls12_381_fr, Bls12_381_fr -> Bls12_381_fr + | _ -> + raise_s + [%message + "Expected matching types for ADD operation" (lhs.type_ : t) (rhs.type_ : t)])) +;; + +let mul ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Mul, [ lhs; rhs ])) + (let open LLTZ.T in + mk_type + ~range + (match lhs.type_.desc, rhs.type_.desc with + | Nat, Nat -> Nat + | Nat, Int -> Int + | Int, Nat -> Int + | Int, Int -> Int + | Mutez, Nat -> Mutez + | Nat, Mutez -> Mutez + | Bls12_381_g1, Bls12_381_fr -> Bls12_381_g1 + | Bls12_381_g2, Bls12_381_fr -> Bls12_381_g2 + | Bls12_381_fr, Bls12_381_fr -> Bls12_381_fr + | Nat, Bls12_381_fr -> Bls12_381_fr + | Int, Bls12_381_fr -> Bls12_381_fr + | Bls12_381_fr, Nat -> Bls12_381_fr + | Bls12_381_fr, Int -> Bls12_381_fr + | _ -> + raise_s + [%message + "Expected matching types for MUL operation" (lhs.type_ : t) (rhs.type_ : t)])) +;; + +let sub ?(range = dummy) (lhs : Expr.t) (rhs : Expr.t) = + match lhs.type_.desc, rhs.type_.desc with + | LLTZ.T.Mutez, LLTZ.T.Mutez -> + create + ~range + (LLTZ.E.Prim (LLTZ.P.Sub_mutez, [ lhs; rhs ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Mutez))) + | _ -> + create + ~range + (LLTZ.E.Prim (LLTZ.P.Sub, [ lhs; rhs ])) + (let open LLTZ.T in + mk_type + ~range + (match lhs.type_.desc, rhs.type_.desc with + | Nat, Nat -> Int + | Nat, Int -> Int + | Int, Nat -> Int + | Int, Int -> Int + | Timestamp, Int -> Timestamp + | Timestamp, Timestamp -> Int + | _ -> + raise_s + [%message + "Expected matching types for SUB operation" (lhs.type_ : t) (rhs.type_ : t)])) +;; + +let sub_mutez ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Sub_mutez, [ lhs; rhs ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Mutez))) +;; + +let lsr_ ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.Lsr, [ lhs; rhs ])) lhs.type_ +;; + +let lsl_ ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.Lsl, [ lhs; rhs ])) lhs.type_ +;; + +let xor ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.Xor, [ lhs; rhs ])) lhs.type_ +;; + +let ediv ?(range = dummy) lhs rhs = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Ediv, [ lhs; rhs ])) + (let open LLTZ.T in + mk_type + ~range + (match lhs.type_.desc, rhs.type_.desc with + | Nat, Nat -> + Option + (mk_type + ~range + (Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range Nat) + ; LLTZ.R.Leaf (None, mk_type ~range Nat) + ]))) + | Nat, Int | Int, Nat | Int, Int -> + Option + (mk_type + ~range + (Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range Int) + ; LLTZ.R.Leaf (None, mk_type ~range Nat) + ]))) + | Mutez, Nat -> + Option + (mk_type + ~range + (Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range Mutez) + ; LLTZ.R.Leaf (None, mk_type ~range Mutez) + ]))) + | Mutez, Mutez -> + Option + (mk_type + ~range + (Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range Nat) + ; LLTZ.R.Leaf (None, mk_type ~range Mutez) + ]))) + | _ -> + raise_s + [%message + "Expected matching types for EDIV operation" (lhs.type_ : t) (rhs.type_ : t)])) +;; + +let div_ ?(range = dummy) (lhs : Expr.t) (rhs : Expr.t) = + if_none + ~range + (ediv ~range lhs rhs) + ~some: + (let var_ty = + tuple_ty + ~range + (Row.Node [ Row.Leaf (None, lhs.type_); Row.Leaf (None, rhs.type_) ]) + in + let var_name = Name.create () in + { lam_var = Var var_name; body = car (variable ~range (Var var_name) var_ty) }) + ~none:(failwith ~range (string ~range "DIV by 0")) +;; + +let mod_ ?(range = dummy) (lhs : Expr.t) (rhs : Expr.t) = + if_none + ~range + (ediv ~range lhs rhs) + ~some: + (let var_ty = + tuple_ty + ~range + (Row.Node [ Row.Leaf (None, lhs.type_); Row.Leaf (None, rhs.type_) ]) + in + let var_name = Name.create () in + { lam_var = Var var_name; body = cdr (variable ~range (Var var_name) var_ty) }) + ~none:(failwith ~range (string ~range "MOD by 0")) +;; + +let and_ ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.And, [ lhs; rhs ])) rhs.type_ +;; + +let or_ ?(range = dummy) lhs rhs = + create ~range (LLTZ.E.Prim (LLTZ.P.Or, [ lhs; rhs ])) lhs.type_ +;; + +let cons ?(range = dummy) head tail = + create ~range (LLTZ.E.Prim (LLTZ.P.Cons, [ head; tail ])) tail.type_ +;; + +let concat1 ?(range = dummy) val1 str2 = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Concat1, [ val1; str2 ])) + (mk_type ~range LLTZ.T.String) +;; + +let concat2 ?(range = dummy) val1 bytes2 = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Concat2, [ val1; bytes2 ])) + (mk_type ~range LLTZ.T.Bytes) +;; + +let get ?(range = dummy) key collection = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Get, [ key; collection ])) + (mk_type + ~range + (match collection.type_.desc with + | LLTZ.T.Map (_, vty) | LLTZ.T.Big_map (_, vty) -> LLTZ.T.Option vty + | _ -> + raise_s + [%message + "Expected a map or big_map with matching key type" + (key.type_ : LLTZ.T.t) + (collection.type_ : LLTZ.T.t)])) +;; + +let mem ?(range = dummy) key collection = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Mem, [ key; collection ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let exec ?(range = dummy) value lambda = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Exec, [ value; lambda ])) + (match lambda.type_.desc with + | LLTZ.T.Function (_, ret_ty) -> ret_ty + | _ -> raise_s [%message "Expected function type" (lambda.type_ : LLTZ.T.t)]) +;; + +let apply ?(range = dummy) value lambda = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Apply, [ value; lambda ])) + (match lambda.type_.desc with + | LLTZ.T.Function + ( { desc = + LLTZ.T.Tuple + (LLTZ.R.Node [ LLTZ.R.Leaf (None, _); LLTZ.R.Leaf (None, ty2) ]) + ; range = _ + } + , ty3 ) -> mk_type ~range (LLTZ.T.Function (ty2, ty3)) + | _ -> raise_s [%message "Expected function type" (lambda.type_ : LLTZ.T.t)]) +;; + +let sapling_verify_update ?(range = dummy) transaction state = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Sapling_verify_update, [ transaction; state ])) + (let open LLTZ.T in + match transaction.type_.desc, state.type_.desc with + | Sapling_transaction _, Sapling_state ms2 -> + mk_type + ~range + (Option + (mk_type + ~range + (Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range Bytes) + ; LLTZ.R.Leaf (None, mk_type ~range Int) + ; LLTZ.R.Leaf (None, mk_type ~range (Sapling_state ms2)) + ])))) + | _ -> + raise_s + [%message + "Expected matching sapling_transaction and sapling_state types" + (transaction.type_ : LLTZ.T.t) + (state.type_ : LLTZ.T.t)]) +;; + +let ticket ?(range = dummy) content amount = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Ticket, [ content; amount ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket content.type_)))) +;; + +let ticket_deprecated ?(range = dummy) content amount = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Ticket_deprecated, [ content; amount ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range (LLTZ.T.Ticket content.type_)))) +;; + +let split_ticket ?(range = dummy) ticket amounts = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Split_ticket, [ ticket; amounts ])) + (mk_type + ~range + (LLTZ.T.Option + (mk_type + ~range + (LLTZ.T.Tuple + (LLTZ.R.Node + [ LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket ticket.type_)) + ; LLTZ.R.Leaf (None, mk_type ~range (LLTZ.T.Ticket ticket.type_)) + ]))))) +;; + +let updaten ?(range = dummy) n value pair = + create ~range (LLTZ.E.Prim (LLTZ.P.Update_n n, [ value; pair ])) (assert false) +;; + +(*TODO*) + +let view ?(range = dummy) name ~return_type ~d ~address = + create + ~range + (LLTZ.E.Prim (LLTZ.P.View (name, return_type), [ d; address ])) + (mk_type ~range (LLTZ.T.Option return_type)) +;; (* Arity 3 *) -let slice ?(range = dummy) offset ~length ~seq = create ~range (LLTZ.E.Prim (LLTZ.P.Slice, [offset; length; seq])) (mk_type ~range (LLTZ.T.Option seq.type_)) -let update ?(range = dummy) key value ~of_ = create ~range (LLTZ.E.Prim (LLTZ.P.Update, [key; value; of_])) of_.type_ -let get_and_update ?(range = dummy) key value ~of_ = create ~range (LLTZ.E.Prim (LLTZ.P.Get_and_update, [key; value; of_])) (mk_type ~range (LLTZ.T.Tuple (LLTZ.R.Node [LLTZ.R.Leaf (None, value.type_); LLTZ.R.Leaf (None, of_.type_)]))) -let transfer_tokens ?(range = dummy) param ~amount ~contract = create ~range (LLTZ.E.Prim (LLTZ.P.Transfer_tokens, [param; amount; contract])) (mk_type ~range LLTZ.T.Operation) -let check_signature ?(range = dummy) key ~signature ~message = create ~range (LLTZ.E.Prim (LLTZ.P.Check_signature, [key; signature; message])) (mk_type ~range LLTZ.T.Bool) -let open_chest ?(range = dummy) chest_key ~chest ~time = create ~range (LLTZ.E.Prim (LLTZ.P.Open_chest, [chest_key; chest; time])) (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Bytes))) - -let convert_list (exprs: LLTZ.E.t list) : LLTZ.E.t Row.t = +let slice ?(range = dummy) offset ~length ~seq = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Slice, [ offset; length; seq ])) + (mk_type ~range (LLTZ.T.Option seq.type_)) +;; + +let update ?(range = dummy) key value ~of_ = + create ~range (LLTZ.E.Prim (LLTZ.P.Update, [ key; value; of_ ])) of_.type_ +;; + +let get_and_update ?(range = dummy) key value ~of_ = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Get_and_update, [ key; value; of_ ])) + (mk_type + ~range + (LLTZ.T.Tuple + (LLTZ.R.Node [ LLTZ.R.Leaf (None, value.type_); LLTZ.R.Leaf (None, of_.type_) ]))) +;; + +let transfer_tokens ?(range = dummy) param ~amount ~contract = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Transfer_tokens, [ param; amount; contract ])) + (mk_type ~range LLTZ.T.Operation) +;; + +let check_signature ?(range = dummy) key ~signature ~message = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Check_signature, [ key; signature; message ])) + (mk_type ~range LLTZ.T.Bool) +;; + +let open_chest ?(range = dummy) chest_key ~chest ~time = + create + ~range + (LLTZ.E.Prim (LLTZ.P.Open_chest, [ chest_key; chest; time ])) + (mk_type ~range (LLTZ.T.Option (mk_type ~range LLTZ.T.Bytes))) +;; + +let convert_list (exprs : LLTZ.E.t list) : LLTZ.E.t Row.t = let converted_row_leaves = List.map ~f:(fun expr -> Row.Leaf (None, expr)) exprs in Row.Node converted_row_leaves +;; let gen_name () = Name.create () -let annon_function var_name var_ty ~body : LLTZ.E.lambda = { lam_var = Var (var_name); body } \ No newline at end of file + +let annon_function var_name var_ty ~body : LLTZ.E.lambda = + { lam_var = Var var_name; body } +;; diff --git a/lib/lltz_ir/expr.ml b/lib/lltz_ir/expr.ml index e103808..662e121 100644 --- a/lib/lltz_ir/expr.ml +++ b/lib/lltz_ir/expr.ml @@ -4,10 +4,10 @@ open Grace type micheline = (Range.t, string) Tezos_micheline.Micheline.node module T = struct - type var = Var of string + type var = Var of string and mut_var = Mut_var of string - and constant = + and constant = | Unit | Bool of bool | Nat of (Z.t[@sexp.opaque]) @@ -30,179 +30,172 @@ module T = struct ; range : Range.t ; type_ : Type.t } - + and binder = var * Type.t - and lambda = { - lam_var: var; - body: t - } - - and lambda_typed = { - lam_var: binder; - body: t; - } - - and lambda2 = { - lam_var1: var; - lam_var2: var; - body: t - } - - and let_in = { - let_var: var; - rhs: t; - in_: t - } - - and lambda_rec = { - mu_var: binder; - lambda: lambda_typed - } - - and app = { - abs: t; - arg: t - } - - and let_mut_in = { - let_var: mut_var; - rhs: t; - in_: t - } - - and if_bool = { - condition: t; - if_true: t; - if_false: t - } - - and if_none = { - subject: t; - if_none: t; - if_some: lambda - } - - and if_cons = { - subject: t; - if_empty: t; - if_nonempty: lambda2 - } - - and if_left = { - subject: t; - if_left: lambda; - if_right: lambda - } - - and while_ = { - cond: t; - body: t - } - - and while_left = { - cond: t; - body: lambda - } - - and for_ = { - index: mut_var; - init: t; - cond: t; - update: t; - body: t - } - - and for_each = { - collection: t; - body: lambda - } - - and map_ = { - collection: t; - map: lambda - } - - and fold_left = { - collection: t; - init: t; - fold: lambda - } - - and fold_right = { - collection: t; - init: t; - fold: lambda - } - - and let_tuple_in = { - components: var list; - rhs: t; - in_: t - } - - and update = { - tuple: t; - component: Row.Path.t; - update: t - } - - and raw_michelson = { - michelson: (micheline[@sexp.opaque] [@equal.ignore] [@compare.ignore]); - args: t list - } - - and global_constant = { - hash: string - } - - and create_contract = { - storage: Type.t; - code: lambda_typed; - delegate: t; - initial_balance: t; - initial_storage: t - } + and lambda = + { lam_var : var + ; body : t + } + + and lambda_typed = + { lam_var : binder + ; body : t + } + + and lambda2 = + { lam_var1 : var + ; lam_var2 : var + ; body : t + } + + and let_in = + { let_var : var + ; rhs : t + ; in_ : t + } + + and lambda_rec = + { mu_var : binder + ; lambda : lambda_typed + } + + and app = + { abs : t + ; arg : t + } + + and let_mut_in = + { let_var : mut_var + ; rhs : t + ; in_ : t + } + + and if_bool = + { condition : t + ; if_true : t + ; if_false : t + } + + and if_none = + { subject : t + ; if_none : t + ; if_some : lambda + } + + and if_cons = + { subject : t + ; if_empty : t + ; if_nonempty : lambda2 + } + + and if_left = + { subject : t + ; if_left : lambda + ; if_right : lambda + } + + and while_ = + { cond : t + ; body : t + } + + and while_left = + { cond : t + ; body : lambda + } + + and for_ = + { index : mut_var + ; init : t + ; cond : t + ; update : t + ; body : t + } + + and for_each = + { collection : t + ; body : lambda + } + + and map_ = + { collection : t + ; map : lambda + } + + and fold_left = + { collection : t + ; init : t + ; fold : lambda + } + + and fold_right = + { collection : t + ; init : t + ; fold : lambda + } + + and let_tuple_in = + { components : var list + ; rhs : t + ; in_ : t + } + + and update = + { tuple : t + ; component : Row.Path.t + ; update : t + } + + and raw_michelson = + { michelson : (micheline[@sexp.opaque] [@equal.ignore] [@compare.ignore]) + ; args : t list + } + + and global_constant = { hash : string } + + and create_contract = + { storage : Type.t + ; code : lambda_typed + ; delegate : t + ; initial_balance : t + ; initial_storage : t + } and desc = (* basic lambda calculus w/ primitives + constants *) | Variable of var - | Let_in of let_in - | Lambda of lambda_typed - | Lambda_rec of lambda_rec - | App of app - | Const of constant - | Prim of Primitive.t * t list - (* mutability *) - | Let_mut_in of let_mut_in - | Deref of mut_var - | Assign of mut_var * t - (* low-level control flow (conditional) *) - | If_bool of if_bool - | If_none of if_none - | If_cons of if_cons - | If_left of if_left - (* low-level control flow (iterative) *) - | While of while_ - | While_left of while_left - | For of for_ - | For_each of for_each - (* high-level control flow (iterative) *) - | Map of map_ - | Fold_left of fold_left - | Fold_right of fold_right - (* tuples *) - | Let_tuple_in of let_tuple_in - | Tuple of t Row.t - | Proj of t * Row.Path.t - | Update of update + | Let_in of let_in + | Lambda of lambda_typed + | Lambda_rec of lambda_rec + | App of app + | Const of constant + | Prim of Primitive.t * t list (* mutability *) + | Let_mut_in of let_mut_in + | Deref of mut_var + | Assign of mut_var * t + (* low-level control flow (conditional) *) + | If_bool of if_bool + | If_none of if_none + | If_cons of if_cons + | If_left of if_left (* low-level control flow (iterative) *) + | While of while_ + | While_left of while_left + | For of for_ + | For_each of for_each (* high-level control flow (iterative) *) + | Map of map_ + | Fold_left of fold_left + | Fold_right of fold_right (* tuples *) + | Let_tuple_in of let_tuple_in + | Tuple of t Row.t + | Proj of t * Row.Path.t + | Update of update (* sums *) | Inj of Type.t Row.Context.t * t - | Match of t * lambda_typed Row.t - (* tezos specific *) - | Raw_michelson of raw_michelson - | Global_constant of global_constant - | Create_contract of create_contract + | Match of t * lambda_typed Row.t (* tezos specific *) + | Raw_michelson of raw_michelson + | Global_constant of global_constant + | Create_contract of create_contract [@@deriving sexp, equal, compare, traverse] end @@ -281,4 +274,4 @@ module Traverse = struct end end -*) \ No newline at end of file +*) diff --git a/lib/lltz_ir/free_vars.ml b/lib/lltz_ir/free_vars.ml index 0a9df91..2ba40f4 100644 --- a/lib/lltz_ir/free_vars.ml +++ b/lib/lltz_ir/free_vars.ml @@ -7,185 +7,163 @@ module LLTZ = struct module R = Row end - (* Computes a map from free variables to their types in the given expression *) let free_vars_with_types (expr : LLTZ.E.t) : LLTZ.T.t String.Map.t = let empty = String.Map.empty in - let () = Printexc.record_backtrace true in - (* Merge two maps, ensuring consistent types for identical variables *) let merge fvs1 fvs2 = Map.merge_skewed fvs1 fvs2 ~combine:(fun ~key:ident type1 type2 -> - if LLTZ.T.equal type1 type2 then - type1 - else - try + if LLTZ.T.equal type1 type2 + then type1 + else ( + try raise_s [%message "free_vars_with_types: inconsistent types in free variables" (ident : string) (type1 : LLTZ.T.t) - (type2 : LLTZ.T.t) - ] - with e -> let backtrace = Printexc.get_backtrace () in - Printf.eprintf "An error occurred: %s\nBacktrace:\n%s\n" ((Exn.to_string e)) backtrace; - exit 1 - ) + (type2 : LLTZ.T.t)] + with + | e -> + let backtrace = Printexc.get_backtrace () in + Printf.eprintf + "An error occurred: %s\nBacktrace:\n%s\n" + (Exn.to_string e) + backtrace; + exit 1)) in - (* Merge a list of maps *) let merge_all fvss = List.fold fvss ~init:empty ~f:merge in - (* Remove bound variables from the map of free variables *) let remove fvs idents = List.fold idents ~init:fvs ~f:Map.remove in - (* Recursively find free variables with types in the expression *) let rec loop (expr : LLTZ.E.t) (bound_vars : string list) : LLTZ.T.t String.Map.t = match expr.desc with | Variable (Var name) -> - if List.mem bound_vars name ~equal:String.equal then - empty - else - String.Map.singleton name expr.type_ - + if List.mem bound_vars name ~equal:String.equal + then empty + else String.Map.singleton name expr.type_ | Let_in { let_var = Var var; rhs; in_ } -> - merge (remove (loop in_ (var :: bound_vars)) [var]) (loop rhs bound_vars) - - | Lambda { lam_var = Var var, var_type; body } -> - loop body (var :: bound_vars) - - | Lambda_rec { mu_var = Var mu, mu_type; lambda = { lam_var = Var var, lam_var_type; body } } -> - loop body (mu :: var :: bound_vars) - - | App { abs; arg } -> - merge (loop abs bound_vars) (loop arg bound_vars) - - | Const _ -> - empty - - | Prim (_, args) -> - merge_all (List.map args ~f:(fun arg -> loop arg bound_vars)) - + merge (remove (loop in_ (var :: bound_vars)) [ var ]) (loop rhs bound_vars) + | Lambda { lam_var = Var var, var_type; body } -> loop body (var :: bound_vars) + | Lambda_rec + { mu_var = Var mu, mu_type; lambda = { lam_var = Var var, lam_var_type; body } } + -> loop body (mu :: var :: bound_vars) + | App { abs; arg } -> merge (loop abs bound_vars) (loop arg bound_vars) + | Const _ -> empty + | Prim (_, args) -> merge_all (List.map args ~f:(fun arg -> loop arg bound_vars)) | Let_mut_in { let_var = Mut_var var; rhs; in_ } -> - merge (remove (loop in_ (var :: bound_vars)) [var]) (loop rhs bound_vars) - + merge (remove (loop in_ (var :: bound_vars)) [ var ]) (loop rhs bound_vars) | Deref (Mut_var var) -> - if List.mem bound_vars var ~equal:String.equal then - empty - else - String.Map.singleton var expr.type_ - + if List.mem bound_vars var ~equal:String.equal + then empty + else String.Map.singleton var expr.type_ | Assign (Mut_var var, value) -> let value_fvs = loop value bound_vars in - if List.mem bound_vars var ~equal:String.equal then - value_fvs - else - merge value_fvs (String.Map.singleton var expr.type_) - + if List.mem bound_vars var ~equal:String.equal + then value_fvs + else merge value_fvs (String.Map.singleton var expr.type_) | If_bool { condition; if_true; if_false } -> - merge_all [loop condition bound_vars; loop if_true bound_vars; loop if_false bound_vars] - + merge_all + [ loop condition bound_vars; loop if_true bound_vars; loop if_false bound_vars ] | If_none { subject; if_none; if_some = { lam_var = Var var; body } } -> let subject_fvs = loop subject bound_vars in let if_none_fvs = loop if_none bound_vars in let some_fvs = loop body (var :: bound_vars) in - merge_all [subject_fvs; if_none_fvs; some_fvs] - - | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body } } -> + merge_all [ subject_fvs; if_none_fvs; some_fvs ] + | If_cons + { subject + ; if_empty + ; if_nonempty = { lam_var1 = Var hd; lam_var2 = Var tl; body } + } -> let subject_fvs = loop subject bound_vars in let if_empty_fvs = loop if_empty bound_vars in let nonempty_fvs = loop body (hd :: tl :: bound_vars) in - merge_all [subject_fvs; if_empty_fvs; nonempty_fvs] - - | If_left { subject; if_left = { lam_var = Var left; body = l }; if_right = { lam_var = Var right; body = r } } -> + merge_all [ subject_fvs; if_empty_fvs; nonempty_fvs ] + | If_left + { subject + ; if_left = { lam_var = Var left; body = l } + ; if_right = { lam_var = Var right; body = r } + } -> let subject_fvs = loop subject bound_vars in let left_fvs = loop l (left :: bound_vars) in let right_fvs = loop r (right :: bound_vars) in - merge_all [subject_fvs; left_fvs; right_fvs] - - | While { cond; body } -> - merge (loop cond bound_vars) (loop body bound_vars) - - | While_left { cond; body = {lam_var = Var var; body=body_lambda} } -> + merge_all [ subject_fvs; left_fvs; right_fvs ] + | While { cond; body } -> merge (loop cond bound_vars) (loop body bound_vars) + | While_left { cond; body = { lam_var = Var var; body = body_lambda } } -> let cond_fvs = loop cond bound_vars in let body_fvs = loop body_lambda (var :: bound_vars) in merge cond_fvs body_fvs - | For { index = Mut_var var; init; cond; update; body } -> let init_fvs = loop init bound_vars in let cond_fvs = loop cond (var :: bound_vars) in let update_fvs = loop update (var :: bound_vars) in let body_fvs = loop body (var :: bound_vars) in - merge_all [init_fvs; cond_fvs; update_fvs; body_fvs] - + merge_all [ init_fvs; cond_fvs; update_fvs; body_fvs ] | For_each { collection; body = { lam_var = Var var; body } } -> - merge (loop collection bound_vars) (remove (loop body (var :: bound_vars)) [var]) - - | Map { collection; map = {lam_var = Var var; body=lam_body} } -> + merge (loop collection bound_vars) (remove (loop body (var :: bound_vars)) [ var ]) + | Map { collection; map = { lam_var = Var var; body = lam_body } } -> let collection_fvs = loop collection bound_vars in let body_fvs = loop lam_body (var :: bound_vars) in merge collection_fvs body_fvs - - | Fold_left { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> + | Fold_left + { collection; init = init_body; fold = { lam_var = Var var; body = fold_body } } + -> let collection_fvs = loop collection bound_vars in let init_fvs = loop init_body bound_vars in let fold_fvs = loop fold_body (var :: bound_vars) in - merge_all [collection_fvs; init_fvs; fold_fvs] - - | Fold_right { collection; init = init_body; fold = {lam_var = Var var; body = fold_body} } -> + merge_all [ collection_fvs; init_fvs; fold_fvs ] + | Fold_right + { collection; init = init_body; fold = { lam_var = Var var; body = fold_body } } + -> let collection_fvs = loop collection bound_vars in let init_fvs = loop init_body bound_vars in let fold_fvs = loop fold_body (var :: bound_vars) in - merge_all [collection_fvs; init_fvs; fold_fvs] - + merge_all [ collection_fvs; init_fvs; fold_fvs ] | Let_tuple_in { components; rhs; in_ } -> let component_names = List.map components ~f:(fun (Var var) -> var) in - merge (remove (loop in_ (component_names @ bound_vars)) component_names) (loop rhs bound_vars) - - | Tuple row -> - compile_row_free_vars_with_types row bound_vars - - | Proj (tuple, _) -> - loop tuple bound_vars - + merge + (remove (loop in_ (component_names @ bound_vars)) component_names) + (loop rhs bound_vars) + | Tuple row -> compile_row_free_vars_with_types row bound_vars + | Proj (tuple, _) -> loop tuple bound_vars | Update { tuple; component; update } -> merge (loop tuple bound_vars) (loop update bound_vars) - - | Inj (_, expr) -> - loop expr bound_vars - + | Inj (_, expr) -> loop expr bound_vars | Match (subject, cases) -> let subject_fvs = loop subject bound_vars in let cases_fvs = compile_row_cases_free_vars_with_types cases bound_vars in merge subject_fvs cases_fvs - - | Raw_michelson {michelson; args} -> + | Raw_michelson { michelson; args } -> merge_all (List.map args ~f:(fun arg -> loop arg bound_vars)) - - | Create_contract { storage; code = {lam_var = Var param_var, param_ty ;body =code_body}; delegate; initial_balance; initial_storage } -> + | Create_contract + { storage + ; code = { lam_var = Var param_var, param_ty; body = code_body } + ; delegate + ; initial_balance + ; initial_storage + } -> let code_body_fvs = loop code_body (param_var :: bound_vars) in let delegate_fvs = loop delegate bound_vars in let initial_balance_fvs = loop initial_balance bound_vars in let initial_storage_fvs = loop initial_storage bound_vars in - merge_all [code_body_fvs; delegate_fvs; initial_balance_fvs; initial_storage_fvs] - + merge_all [ code_body_fvs; delegate_fvs; initial_balance_fvs; initial_storage_fvs ] | Global_constant _ -> assert false - and compile_row_free_vars_with_types row bound_vars = match row with | LLTZ.R.Node nodes -> - List.map nodes ~f:(fun node -> (compile_row_free_vars_with_types node bound_vars)) + List.map nodes ~f:(fun node -> compile_row_free_vars_with_types node bound_vars) |> merge_all - | LLTZ.R.Leaf (_, expr) -> - loop expr bound_vars - + | LLTZ.R.Leaf (_, expr) -> loop expr bound_vars and compile_row_cases_free_vars_with_types cases bound_vars = match cases with | LLTZ.R.Node nodes -> - List.map nodes ~f:(fun case -> compile_row_cases_free_vars_with_types case bound_vars) + List.map nodes ~f:(fun case -> + compile_row_cases_free_vars_with_types case bound_vars) |> merge_all | LLTZ.R.Leaf (_, { lam_var = Var var, var_ty; body }) -> - remove (loop body (var :: bound_vars)) [var] - - in loop expr [] \ No newline at end of file + remove (loop body (var :: bound_vars)) [ var ] + in + loop expr [] +;; diff --git a/lib/lltz_ir/name.ml b/lib/lltz_ir/name.ml index 9098fd7..643256a 100644 --- a/lib/lltz_ir/name.ml +++ b/lib/lltz_ir/name.ml @@ -3,4 +3,5 @@ let counter = ref 0 let create () = let name = "name_var_4sfa9wjas8" ^ string_of_int !counter in counter := !counter + 1; - name \ No newline at end of file + name +;; diff --git a/lib/lltz_ir/row.ml b/lib/lltz_ir/row.ml index 8f50f49..02005e3 100644 --- a/lib/lltz_ir/row.ml +++ b/lib/lltz_ir/row.ml @@ -58,6 +58,7 @@ let rec pp ppa ppf t = ts | Leaf (label, x) -> Format.fprintf ppf "Leaf (%a, %a)" Format.(pp_print_option pp_label) label ppa x +;; module Context = struct type 'a t = @@ -115,3 +116,4 @@ let rec find_leaf row = (match find_leaf hd with | Some x -> Some x | None -> find_leaf (Node tl))) +;; diff --git a/lib/lltz_michelson/lltz_michelson.ml b/lib/lltz_michelson/lltz_michelson.ml index 7eb3b59..3e13379 100644 --- a/lib/lltz_michelson/lltz_michelson.ml +++ b/lib/lltz_michelson/lltz_michelson.ml @@ -7,7 +7,6 @@ module Stack = Stack module Type = Type module Instruction = Instruction module Slot = Slot - open Core module LLTZ = struct @@ -79,9 +78,9 @@ and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = match const with | Unit -> Michelson.Ast.Instruction.unit | Bool b -> if b then Michelson.Ast.true_ else Michelson.Ast.false_ - | Nat n -> Michelson.Ast.int_of_z (n) - | Int n -> Michelson.Ast.int_of_z (n) - | Mutez n -> Michelson.Ast.int_of_z (n) + | Nat n -> Michelson.Ast.int_of_z n + | Int n -> Michelson.Ast.int_of_z n + | Mutez n -> Michelson.Ast.int_of_z n | String s -> Michelson.Ast.string s | Key s -> Michelson.Ast.string s | Key_hash s -> Michelson.Ast.string s @@ -93,6 +92,7 @@ and convert_constant (const : LLTZ.E.constant) : Michelson.Ast.t = | Bls12_381_g2 s -> Michelson.Ast.string s | Bls12_381_fr s -> Michelson.Ast.string s | Signature s -> Michelson.Ast.string s +;; let get_const_type (const : LLTZ.E.constant) : Michelson.Ast.t = match const with @@ -112,6 +112,7 @@ let get_const_type (const : LLTZ.E.constant) : Michelson.Ast.t = | Bls12_381_g2 _ -> Michelson.T.bls12_381_g2 | Bls12_381_fr _ -> Michelson.T.bls12_381_fr | Signature _ -> Michelson.T.signature +;; let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = let open Michelson.Ast.Instruction in @@ -205,9 +206,10 @@ let convert_primitive (prim : LLTZ.P.t) : Michelson.Ast.t = | Transfer_tokens -> transfer_tokens | Check_signature -> check_signature | Open_chest -> open_chest +;; let rec compile : LLTZ.E.t -> t = - fun expr -> + fun expr -> seq [ (match expr.desc with | Variable (Var name) -> compile_variable name @@ -215,8 +217,9 @@ let rec compile : LLTZ.E.t -> t = | Lambda { lam_var = Var var, lam_var_type; body } -> compile_lambda var lam_var_type body | Lambda_rec - { mu_var = Var mu, mu_type; lambda = {lam_var = Var var, lam_var_type; body} } -> - compile_lambda_rec var lam_var_type mu body + { mu_var = Var mu, mu_type + ; lambda = { lam_var = Var var, lam_var_type; body } + } -> compile_lambda_rec var lam_var_type mu body | App { abs; arg } -> compile_app abs arg | Const constant -> compile_const constant | Prim (primitive, args) -> compile_prim primitive args @@ -225,23 +228,39 @@ let rec compile : LLTZ.E.t -> t = | Assign (Mut_var var, value) -> compile_assign var value | If_bool { condition; if_true; if_false } -> compile_if_bool condition if_true if_false - | If_none { subject; if_none; if_some = {lam_var = Var var, var_type; body = some} } -> + | If_none + { subject; if_none; if_some = { lam_var = Var var, var_type; body = some } } -> compile_if_none subject if_none (var, some) - | If_cons { subject; if_empty; if_nonempty = { lam_var1 = Var hd, var1_ty; lam_var2 = Var tl, var2_ty; body =nonempty }} -> - compile_if_cons subject if_empty (hd, tl, nonempty) - | If_left { subject; if_left = {lam_var = Var left, left_ty; body =l}; if_right = {lam_var = Var right, right_ty; body = r} } -> - compile_if_left subject (left, l) (right, r) + | If_cons + { subject + ; if_empty + ; if_nonempty = + { lam_var1 = Var hd, var1_ty; lam_var2 = Var tl, var2_ty; body = nonempty } + } -> compile_if_cons subject if_empty (hd, tl, nonempty) + | If_left + { subject + ; if_left = { lam_var = Var left, left_ty; body = l } + ; if_right = { lam_var = Var right, right_ty; body = r } + } -> compile_if_left subject (left, l) (right, r) | While { cond; body } -> compile_while cond body - | While_left { cond; body = {lam_var = Var var, var_ty; body=body_lambda} } -> compile_while_left cond var body_lambda + | While_left { cond; body = { lam_var = Var var, var_ty; body = body_lambda } } -> + compile_while_left cond var body_lambda | For { index = Mut_var var; init; cond; update; body } -> compile_for var init cond update body - | For_each { collection; body = {lam_var = Var var, var_ty; body = lambda_body} } -> - compile_for_each collection var lambda_body - | Map { collection; map = {lam_var = Var var, var_ty; body=lam_body} } -> compile_map collection var lam_body - | Fold_left { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } -> - compile_fold_left collection init_body var fold_body - | Fold_right { collection; init = init_body; fold = {lam_var = Var var, var_ty; body = fold_body} } - -> compile_fold_right collection init_body var fold_body + | For_each { collection; body = { lam_var = Var var, var_ty; body = lambda_body } } + -> compile_for_each collection var lambda_body + | Map { collection; map = { lam_var = Var var, var_ty; body = lam_body } } -> + compile_map collection var lam_body + | Fold_left + { collection + ; init = init_body + ; fold = { lam_var = Var var, var_ty; body = fold_body } + } -> compile_fold_left collection init_body var fold_body + | Fold_right + { collection + ; init = init_body + ; fold = { lam_var = Var var, var_ty; body = fold_body } + } -> compile_fold_right collection init_body var fold_body | Let_tuple_in { components; rhs; in_ } -> compile_let_tuple_in components rhs in_ | Tuple row -> compile_tuple row | Proj (tuple, path) -> compile_proj tuple path @@ -250,7 +269,12 @@ let rec compile : LLTZ.E.t -> t = | Match (subject, cases) -> compile_match subject cases | Raw_michelson node -> assert false | Create_contract - { storage; code = {lam_var = Var param_var, param_ty ;body =code_body}; delegate; initial_balance; initial_storage } -> + { storage + ; code = { lam_var = Var param_var, param_ty; body = code_body } + ; delegate + ; initial_balance + ; initial_storage + } -> compile_create_contract storage param_var @@ -324,7 +348,11 @@ and compile_while invariant body = (* Compile a while-left expression by compiling the invariant, then applying the loop-left instruction to the body and invariant. *) and compile_while_left invariant var body_lambda = - seq [ compile invariant; loop_left (seq [ Slot.let_ (`Ident var) ~in_:(compile body_lambda); compile invariant ]) ] + seq + [ compile invariant + ; loop_left + (seq [ Slot.let_ (`Ident var) ~in_:(compile body_lambda); compile invariant ]) + ] (* Compile a for expression by compiling the initial value, invariant, variant, and body, then applying the loop to the sequence of body, variant, and invariant. *) @@ -353,9 +381,9 @@ and compile_proj tuple path = trace (seq ([ tuple_expanded_instr ] - @ [ (* Keep the last value, drop the intermediate ones and the tuple *) - trace (dip 1 (drop (List.length gets - 1))) - ])) + @ [ (* Keep the last value, drop the intermediate ones and the tuple *) + trace (dip 1 (drop (List.length gets - 1))) + ])) (* Compile an update expression by compiling the tuple row, getting the nth element, compiling the update value, and combining the values back together into tuple. *) and compile_update tuple component update = @@ -448,7 +476,7 @@ and compile_create_contract = let storage_ty = convert_type storage in let param_ty = convert_type param_ty in - let code_instr = seq[Slot.let_ (`Ident param_var) ~in_:(compile code_body)] in + let code_instr = seq [ Slot.let_ (`Ident param_var) ~in_:(compile code_body) ] in seq [ compile delegate (*TODO possibly needs triple lambda*) ; compile initial_balance @@ -461,22 +489,12 @@ and compile_create_contract (* Compile for-each expression by compiling the collection, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the body. *) and compile_for_each collection var body = let coll_instr = compile collection in - seq - [ coll_instr - ; iter - (seq - [ - Slot.let_ (`Ident var) ~in_:(compile body) - ]) - ] + seq [ coll_instr; iter (seq [ Slot.let_ (`Ident var) ~in_:(compile body) ]) ] (* Compile map expression by compiling the collection, then applying the MAP instruction that maps over the collection and binds the values to the variables in the function body. *) and compile_map collection var lam_body = let coll_instr = compile collection in - seq - [ coll_instr - ; map_ (seq [ Slot.let_ (`Ident var) ~in_:(compile lam_body) ]) - ] + seq [ coll_instr; map_ (seq [ Slot.let_ (`Ident var) ~in_:(compile lam_body) ]) ] (* Compile fold-left expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) and compile_fold_left collection init_body var fold_body = @@ -486,9 +504,11 @@ and compile_fold_left collection init_body var fold_body = [ init_instr ; coll_instr ; iter - (seq [ - pair; (* Creates pair (acc, val) *) - Slot.let_ (`Ident var) ~in_:(compile fold_body); ]) + (seq + [ pair + ; (* Creates pair (acc, val) *) + Slot.let_ (`Ident var) ~in_:(compile fold_body) + ]) ] (* Compile fold-right expression by compiling the collection, initial value, and body, then applying the ITER instruction that iterates over the collection and binds the values to the variables in the function body. *) @@ -499,10 +519,7 @@ and compile_fold_right collection init_body var fold_body = [ init_instr ; coll_instr ; (*TODO: reverse the collection - once rest of the code is validated, it is easily done with dsl*) - iter - (seq [ - pair; - Slot.let_ (`Ident var) ~in_:(compile fold_body); ]) + iter (seq [ pair; Slot.let_ (`Ident var) ~in_:(compile fold_body) ]) ] and compile_inj context expr = @@ -527,19 +544,18 @@ and compile_inj context expr = in seq ([ compile expr; left mid_ty ] - (* Rights - traverses all right_instrs_types in reverse order except last and makes right instructions*) - @ - match right_instrs_types with - | hd::tl -> List.map (List.rev tl) ~f:(fun ty -> right ty) - | [] -> [] - ) + (* Rights - traverses all right_instrs_types in reverse order except last and makes right instructions*) + @ + match right_instrs_types with + | hd :: tl -> List.map (List.rev tl) ~f:(fun ty -> right ty) + | [] -> []) and compile_row_of_lambdas row = match row with | LLTZ.R.Node nodes -> let compiled_nodes = List.map nodes ~f:compile_row_of_lambdas in Instruction.seq (compiled_nodes @ [ Instruction.pair_n (List.length compiled_nodes) ]) - | LLTZ.R.Leaf (_, LLTZ.E.{lam_var = Var var, var_type; body}) -> + | LLTZ.R.Leaf (_, LLTZ.E.{ lam_var = Var var, var_type; body }) -> compile (LLTZ.Dsl.lambda (Var var, var_type) ~body) and compile_match subject cases = @@ -558,5 +574,6 @@ and compile_matching cases = [ if_left ~left:(compile_matching hd) ~right:(compile_matching (LLTZ.R.Node tl)) ] | [] -> seq []) - | LLTZ.R.Leaf (_, {lam_var = Var var, var_type; body}) -> + | LLTZ.R.Leaf (_, { lam_var = Var var, var_type; body }) -> seq [ compile (LLTZ.Dsl.lambda (Var var, var_type) ~body); exec ] +;; diff --git a/lib/michelson/ast.ml b/lib/michelson/ast.ml index 0570c19..c1eb554 100644 --- a/lib/michelson/ast.ml +++ b/lib/michelson/ast.ml @@ -1,4 +1,4 @@ -open Core +open Core open Tezos_micheline module Prim = struct @@ -554,7 +554,7 @@ module Prim = struct | G of Global_storage.t [@@deriving equal, compare, sexp] - let to_string = function + let to_string = function | K keyword -> Keyword.to_string keyword | I instr -> Instruction.to_string instr | T type_ -> Type.to_string type_ @@ -567,7 +567,7 @@ module Prim = struct match fs with | f :: fs -> (try f received with - | _ -> loop fs) + | _ -> loop fs) | [] -> raise_s [%message "Michelson.Prim.of_string: unexpected input" (received : string)] @@ -615,9 +615,9 @@ let iter (t : t) ~f = let analyze_instructions t = let tbl : (string, int) Hashtbl.t = Hashtbl.create (module String) in iter t ~f:(fun prim -> - match prim with - | I instr -> Hashtbl.incr tbl (Prim.Instruction.to_string instr) - | _ -> ()); + match prim with + | I instr -> Hashtbl.incr tbl (Prim.Instruction.to_string instr) + | _ -> ()); tbl ;; @@ -661,26 +661,28 @@ module Type = struct let never = prim (T Never) let operation = prim (T Operation) let option ty = prim ~arguments:[ ty ] (T Option) + let or_ ?(annot1 = None) ?(annot2 = None) t1 t2 = match annot1, annot2 with | None, None -> prim ~arguments:[ t1; t2 ] (T Or) - | Some a1, None -> prim ~annot:[a1] ~arguments:[ t1; t2 ] (T Or) + | Some a1, None -> prim ~annot:[ a1 ] ~arguments:[ t1; t2 ] (T Or) | None, Some _ -> assert false - | Some a1, Some a2 -> prim ~annot:[a1; a2] ~arguments:[ t1; t2 ] (T Or) + | Some a1, Some a2 -> prim ~annot:[ a1; a2 ] ~arguments:[ t1; t2 ] (T Or) + ;; let pair ?(annot1 = None) ?(annot2 = None) t1 t2 = match annot1, annot2 with | None, None -> prim ~arguments:[ t1; t2 ] (T Pair) - | Some a1, None -> prim ~annot:[a1] ~arguments:[ t1; t2 ] (T Pair) + | Some a1, None -> prim ~annot:[ a1 ] ~arguments:[ t1; t2 ] (T Pair) | None, Some _ -> assert false - | Some a1, Some a2 -> prim ~annot:[a1; a2] ~arguments:[ t1; t2 ] (T Pair) + | Some a1, Some a2 -> prim ~annot:[ a1; a2 ] ~arguments:[ t1; t2 ] (T Pair) + ;; - let pair_n ts = + let pair_n ts = assert (List.length ts >= 2); prim ~arguments:ts (T Pair) ;; - let sampling_state n = prim ~arguments:[ n ] (T Sapling_state) let sapling_transaction n = prim ~arguments:[ n ] (T Sapling_transaction) let set cty = prim ~arguments:[ cty ] (T Set) @@ -689,10 +691,8 @@ module Type = struct let ticket cty = prim ~arguments:[ cty ] (T Ticket) let timestamp = prim (T Timestamp) let unit = prim (T Unit) - let chest = prim (T Chest) let tx_rollup_l2_address = prim (T Tx_rollup_l2_address) - let chest_key = prim (T Chest_key) end @@ -716,8 +716,23 @@ module Instruction = struct let compare = prim (I Compare) let concat = prim (I Concat) let cons = prim (I Cons) - let contract annot ty = prim ~annot:(match annot with | None -> [] | Some a -> [a]) ~arguments:[ ty ] (I Contract) - let create_contract storage parameter instr1 = prim ~arguments:[ parameter; storage; instr1 ] (I Create_contract) (*Any reason why this was just Contract before?*) + + let contract annot ty = + prim + ~annot: + (match annot with + | None -> [] + | Some a -> [ a ]) + ~arguments:[ ty ] + (I Contract) + ;; + + let create_contract storage parameter instr1 = + prim ~arguments:[ parameter; storage; instr1 ] (I Create_contract) + ;; + + (*Any reason why this was just Contract before?*) + let dig_n n = prim ~arguments:[ int n ] (I Dig) let dip instr = prim ~arguments:[ seq instr ] (I Dip) let dip_n n instr = prim ~arguments:[ int n; seq instr ] (I Dip) @@ -727,12 +742,15 @@ module Instruction = struct let dup = prim (I Dup) let dup_n n = prim ~arguments:[ int n ] (I Dup) let ediv = prim (I Ediv) - let emit opt ty_opt = + + let emit opt ty_opt = match opt, ty_opt with | None, None -> prim (I Emit) - | Some s, None -> prim ~annot:[s] (I Emit) + | Some s, None -> prim ~annot:[ s ] (I Emit) | None, Some ty -> prim ~arguments:[ ty ] (I Emit) - | Some s, Some ty -> prim ~annot:[s] ~arguments:[ty ] (I Emit) + | Some s, Some ty -> prim ~annot:[ s ] ~arguments:[ ty ] (I Emit) + ;; + let empty_big_map kty vty = prim ~arguments:[ kty; vty ] (I Empty_big_map) let empty_map kty vty = prim ~arguments:[ kty; vty ] (I Empty_map) let empty_set cty = prim ~arguments:[ cty ] (I Empty_set) @@ -777,12 +795,15 @@ module Instruction = struct let open_chest = prim (I Open_chest) let or_ = prim (I Or) let pack = prim (I Pack) - let pair ?(left_annot=None) ?(right_annot=None) () = + + let pair ?(left_annot = None) ?(right_annot = None) () = match left_annot, right_annot with | None, None -> prim (I Pair) - | Some l, None -> prim ~annot:[l] (I Pair) - | None, Some r -> prim ~annot:[r] (I Pair) - | Some l, Some r -> prim ~annot:[l; r] (I Pair) + | Some l, None -> prim ~annot:[ l ] (I Pair) + | None, Some r -> prim ~annot:[ r ] (I Pair) + | Some l, Some r -> prim ~annot:[ l; r ] (I Pair) + ;; + let pair_n n = prim ~arguments:[ int n ] (I Pair) let pairing_check = prim (I Pairing_check) let push ty x = prim ~arguments:[ ty; x ] (I Push) @@ -791,10 +812,13 @@ module Instruction = struct let right ty1 = prim ~arguments:[ ty1 ] (I Right) let sapling_verify_update = prim (I Sapling_verify_update) let sapling_empty_state ms = prim ~arguments:[ ms ] (I Sapling_empty_state) - let self opt = + + let self opt = match opt with | None -> prim (I Self) | Some s -> prim ~annot:[ s ] (I Self) + ;; + let self_address = prim (I Self_address) let sender = prim (I Sender) let set_delegate = prim (I Set_delegate) @@ -839,7 +863,8 @@ module Contract = struct let dummy code = { parameter = Type.unit ; storage = Type.unit - ; code = seq Instruction.([ drop ] @ code @ [ drop; unit; nil Type.operation; pair ()]) + ; code = + seq Instruction.([ drop ] @ code @ [ drop; unit; nil Type.operation; pair () ]) } ;; @@ -850,4 +875,4 @@ module Contract = struct ; prim ~arguments:[ code ] (K Code) ] ;; -end \ No newline at end of file +end diff --git a/lib/michelson/optimisations/oasis_core/michelson.ml b/lib/michelson/optimisations/oasis_core/michelson.ml index 31b32b9..dc9a1b5 100644 --- a/lib/michelson/optimisations/oasis_core/michelson.ml +++ b/lib/michelson/optimisations/oasis_core/michelson.ml @@ -9,44 +9,44 @@ include Michelson_base.Typing open Printf let full_types_and_tags = false - -let cata_mtype_stripped f = - cata_mtype (fun ?annot_type:_ ?annot_variable:_ x -> f x) +let cata_mtype_stripped f = cata_mtype (fun ?annot_type:_ ?annot_variable:_ x -> f x) let has_missing_type ~path = cata_mtype_stripped (function | MT_var t -> - [Printf.sprintf "Missing type in %s (unknown type variable: %s)" path t] + [ Printf.sprintf "Missing type in %s (unknown type variable: %s)" path t ] | x -> fold_mtype_f ( @ ) [] x) +;; let remove_annots = cata_mtype_stripped (function | MT2 (Pair _, fst, snd) -> mt_pair fst snd | MT2 (Or _, left, right) -> mt_or left right | x -> mk_mtype x) +;; type ad_step = | A | D -[@@deriving eq, ord, show {with_path = false}] +[@@deriving eq, ord, show { with_path = false }] -type tezos_int = Bigint.t [@@deriving eq, ord, show {with_path = false}] +type tezos_int = Bigint.t [@@deriving eq, ord, show { with_path = false }] type stack = | Stack_ok of mtype list | Stack_failed -[@@deriving eq, ord, show {with_path = false}] +[@@deriving eq, ord, show { with_path = false }] -type 'instr view = { - name : string +type 'instr view = + { name : string ; pure : bool ; doc : string ; tparameter : mtype option ; treturn : mtype ; onchain_code : 'instr option ; offchain_code : 'instr -} -[@@deriving eq, ord, show {with_path = false}, map, fold] + } +[@@deriving eq, ord, show { with_path = false }, map, fold] type ('i, 'literal) instr_f = | MI0 of mtype prim0 @@ -56,12 +56,12 @@ type ('i, 'literal) instr_f = | MI3 of prim3 | MIerror of string | MIcomment of string list - | MImich of { - name : string + | MImich of + { name : string ; parsed : Micheline.t ; typesIn : mtype list ; typesOut : mtype list - } + } | MIdip of 'i | MIdipn of int * 'i | MIloop of 'i @@ -86,16 +86,16 @@ type ('i, 'literal) instr_f = | MIsetField of ad_step list | MIlambda of mtype * mtype * 'i | MIlambda_rec of mtype * mtype * 'i - | MIcreate_contract of { - tparameter : mtype * string option + | MIcreate_contract of + { tparameter : mtype * string option ; tstorage : mtype ; code : 'i ; views : 'i view list - } + } | MIconcat1 | MIconcat2 | MIconcat_unresolved -[@@deriving eq, ord, show {with_path = false}, map, fold] +[@@deriving eq, ord, show { with_path = false }, map, fold] type ('instr, 'literal) literal_f = | Int of tezos_int @@ -114,13 +114,12 @@ type ('instr, 'literal) literal_f = | Lambda_rec of 'instr | AnyMap of ('literal * 'literal) list | Constant of string -[@@deriving eq, ord, show {with_path = false}, map, fold] +[@@deriving eq, ord, show { with_path = false }, map, fold] let sequence_literal_f = let open Result in function - | (Int _ | Bool _ | String _ | Bytes _ | Unit | None_ | Constant _) as l -> - Ok l + | (Int _ | Bool _ | String _ | Bytes _ | Unit | None_ | Constant _) as l -> Ok l | Pair (x, y) -> map2 (fun x y -> Pair (x, y)) x y | Left x -> map (fun x -> Left x) x | Right x -> map (fun x -> Right x) x @@ -130,12 +129,14 @@ let sequence_literal_f = | AnyMap xs -> map (fun x -> AnyMap x) (map_list (uncurry (map2 pair)) xs) | Instr x -> map (fun x -> Instr x) x | Lambda_rec x -> map (fun x -> Lambda_rec x) x +;; -let sequence_view ({onchain_code; offchain_code} as view) = +let sequence_view ({ onchain_code; offchain_code } as view) = let open Result in let+ onchain_code = sequence_option onchain_code and+ offchain_code = offchain_code in - {view with onchain_code; offchain_code} + { view with onchain_code; offchain_code } +;; let sequence_instr_f = let open Result in @@ -152,20 +153,15 @@ let sequence_instr_f = | MIif_cons (i1, i2) -> map2 (fun i1 i2 -> MIif_cons (i1, i2)) i1 i2 | MIlambda (t1, t2, i) -> map (fun x -> MIlambda (t1, t2, x)) i | MIlambda_rec (t1, t2, i) -> map (fun x -> MIlambda_rec (t1, t2, x)) i - | MIcreate_contract {tparameter; tstorage; code; views} -> - let+ code = code - and+ views = map_list sequence_view views in - MIcreate_contract {tparameter; tstorage; code; views} + | MIcreate_contract { tparameter; tstorage; code; views } -> + let+ code = code + and+ views = map_list sequence_view views in + MIcreate_contract { tparameter; tstorage; code; views } | MIseq is -> map (fun is -> MIseq is) (sequence_list is) | MIpush (t, l) -> map (fun l -> MIpush (t, l)) l | ( MI0 _ | MI1 _ | MI1_fail _ | MI2 _ | MI3 - ( Slice - | Update - | Get_and_update - | Transfer_tokens - | Check_signature - | Open_chest ) + (Slice | Update | Get_and_update | Transfer_tokens | Check_signature | Open_chest) | MIdrop | MIswap | MIerror _ @@ -182,84 +178,64 @@ let sequence_instr_f = | MIconcat1 | MIconcat2 | MIconcat_unresolved ) as instr -> return instr +;; -type instr = {instr : (instr, literal) instr_f} +type instr = { instr : (instr, literal) instr_f } -and literal = {literal : (instr, literal) literal_f} -[@@deriving eq, ord, show {with_path = false}, map, fold] +and literal = { literal : (instr, literal) literal_f } +[@@deriving eq, ord, show { with_path = false }, map, fold] -type ('i, 'l) alg = { - f_instr : ('i, 'l) instr_f -> 'i +type ('i, 'l) alg = + { f_instr : ('i, 'l) instr_f -> 'i ; f_literal : ('i, 'l) literal_f -> 'l -} + } -let cata {f_instr; f_literal} = - let rec cata_instr {instr} = - f_instr (map_instr_f cata_instr cata_literal instr) - and cata_literal {literal} = +let cata { f_instr; f_literal } = + let rec cata_instr { instr } = f_instr (map_instr_f cata_instr cata_literal instr) + and cata_literal { literal } = f_literal (map_literal_f cata_instr cata_literal literal) in - (cata_instr, cata_literal) + cata_instr, cata_literal +;; let cata_instr alg = fst (cata alg) - let cata_literal alg = snd (cata alg) module MLiteral = struct let compare x y = compare_literal x y - - let int i = {literal = Int i} - - let small_int i = {literal = Int (Bigint.of_int i)} - - let bool x = {literal = Bool x} - - let string x = {literal = String x} - - let bytes x = {literal = Bytes x} - - let unit = {literal = Unit} - - let left x = {literal = Left x} - - let right x = {literal = Right x} - - let some x = {literal = Some_ x} - - let pair x1 x2 = {literal = Pair (x1, x2)} - - let none = {literal = None_} - - let list xs = {literal = Seq xs} - - let set xs = {literal = Seq (Base.List.dedup_and_sort ~compare xs)} - - let seq xs = {literal = Seq xs} - - let elt k v = {literal = Elt (k, v)} + let int i = { literal = Int i } + let small_int i = { literal = Int (Bigint.of_int i) } + let bool x = { literal = Bool x } + let string x = { literal = String x } + let bytes x = { literal = Bytes x } + let unit = { literal = Unit } + let left x = { literal = Left x } + let right x = { literal = Right x } + let some x = { literal = Some_ x } + let pair x1 x2 = { literal = Pair (x1, x2) } + let none = { literal = None_ } + let list xs = { literal = Seq xs } + let set xs = { literal = Seq (Base.List.dedup_and_sort ~compare xs) } + let seq xs = { literal = Seq xs } + let elt k v = { literal = Elt (k, v) } let mk_map xs = - { - literal = + { literal = AnyMap - (Base.List.dedup_and_sort - ~compare:(fun (k1, _) (k2, _) -> compare k1 k2) - xs) + (Base.List.dedup_and_sort ~compare:(fun (k1, _) (k2, _) -> compare k1 k2) xs) } + ;; let sapling_empty_state = seq [] - - let constant hash = {literal = Constant hash} - - let instr body = {literal = Instr body} - - let lambda_rec body = {literal = Lambda_rec body} + let constant hash = { literal = Constant hash } + let instr body = { literal = Instr body } + let lambda_rec body = { literal = Lambda_rec body } let rec to_michelson_string instr_to_string ~protect : literal -> string = let continue ~protect = to_michelson_string instr_to_string ~protect in let open Printf in let prot ~protect s = if protect then sprintf "(%s)" s else s in - fun {literal} -> + fun { literal } -> match literal with | Int i -> Big_int.string_of_big_int i | Unit -> "Unit" @@ -267,33 +243,34 @@ module MLiteral = struct | Bool true -> "True" | Bool false -> "False" | Pair (l, r) -> - prot ~protect - (sprintf "Pair %s %s" (continue ~protect:true l) - (continue ~protect:true r)) + prot + ~protect + (sprintf "Pair %s %s" (continue ~protect:true l) (continue ~protect:true r)) | None_ -> "None" | Left l -> prot ~protect (sprintf "Left %s" (continue ~protect:true l)) | Right l -> prot ~protect (sprintf "Right %s" (continue ~protect:true l)) | Some_ l -> prot ~protect (sprintf "Some %s" (continue ~protect:true l)) | Bytes string_bytes -> "0x" ^ Hex.(show (of_string string_bytes)) | Seq xs -> - sprintf "{%s}" - (String.concat "; " - (List.filter_map - (fun x -> - let x = continue ~protect:false x in - if x = "" then None else Some x) - xs)) + sprintf + "{%s}" + (String.concat + "; " + (List.filter_map + (fun x -> + let x = continue ~protect:false x in + if x = "" then None else Some x) + xs)) | AnyMap xs -> - let f (k, v) = {literal = Elt (k, v)} in - let xs = {literal = Seq (List.map f xs)} in - continue ~protect xs + let f (k, v) = { literal = Elt (k, v) } in + let xs = { literal = Seq (List.map f xs) } in + continue ~protect xs | Elt (k, v) -> - sprintf "Elt %s %s" (continue ~protect:true k) - (continue ~protect:true v) + sprintf "Elt %s %s" (continue ~protect:true k) (continue ~protect:true v) | Instr i -> instr_to_string i - | Lambda_rec i -> - prot ~protect (sprintf "Lambda_rec %s" (instr_to_string i)) + | Lambda_rec i -> prot ~protect (sprintf "Lambda_rec %s" (instr_to_string i)) | Constant s -> prot ~protect (sprintf "constant %S" s) + ;; let to_michelson_string = to_michelson_string ~protect:true end @@ -304,17 +281,19 @@ let string_of_ad_path p = | D -> "D" in String.concat "" (List.map f p) +;; let insert_field_annot a e = let open Sexplib.Sexp in match a with | None | Some "" -> e - | Some a -> ( - let a = Atom ("%" ^ a) in - match e with - | Atom s -> List [Atom s; a] - | List (Atom s :: xs) -> List (Atom s :: a :: xs) - | _ -> assert false) + | Some a -> + let a = Atom ("%" ^ a) in + (match e with + | Atom s -> List [ Atom s; a ] + | List (Atom s :: xs) -> List (Atom s :: a :: xs) + | _ -> assert false) +;; let s_expression_of_mtype ?full ?human = let is_full = full = Some () in @@ -326,208 +305,207 @@ let s_expression_of_mtype ?full ?human = | None -> None | Some s -> Some (Atom (pref ^ s)) in - List.somes [get ":" annot_type; get "@" annot_variable] + List.somes [ get ":" annot_type; get "@" annot_variable ] in let mk = function | [] -> assert false - | [x] -> x + | [ x ] -> x | xs -> List xs in let atom s = mk (Atom s :: annots) in let call s l = List ((Atom s :: annots) @ l) in match annot_variable with - | Some a when is_human -> ( - match Base.String.split ~on:'.' a with - | [] -> assert false - | hd :: xs -> - let rec collapse = function - | ("left" | "right") :: xs -> collapse xs - | [last] -> Atom ("@" ^ hd ^ "%" ^ last) - | _ -> Atom ("@" ^ a) - in - collapse xs) - | _ -> ( - match mt with - | MT0 t -> - let s, memo = string_of_type0 t in - Option.cata (atom s) (fun memo -> call s [Atom memo]) memo - | MT1 (t, t1) -> call (string_of_type1 t) [t1] - | MT2 (t, t1, t2) -> - let t, a1, a2 = string_of_type2 t in - call t [insert_field_annot a1 t1; insert_field_annot a2 t2] - | MT_var s -> call "missing_type_conversion" [Atom s]) + | Some a when is_human -> + (match Base.String.split ~on:'.' a with + | [] -> assert false + | hd :: xs -> + let rec collapse = function + | ("left" | "right") :: xs -> collapse xs + | [ last ] -> Atom ("@" ^ hd ^ "%" ^ last) + | _ -> Atom ("@" ^ a) + in + collapse xs) + | _ -> + (match mt with + | MT0 t -> + let s, memo = string_of_type0 t in + Option.cata (atom s) (fun memo -> call s [ Atom memo ]) memo + | MT1 (t, t1) -> call (string_of_type1 t) [ t1 ] + | MT2 (t, t1, t2) -> + let t, a1, a2 = string_of_type2 t in + call t [ insert_field_annot a1 t1; insert_field_annot a2 t2 ] + | MT_var s -> call "missing_type_conversion" [ Atom s ]) in cata_mtype f +;; let buffer_mtype_sexp ~html b = let rec buffer : Sexplib.Sexp.t -> _ = function | Atom s -> - Buffer.add_string b (Base.Sexp.Private.mach_maybe_esc_str s) - (* See how this is used in `_opam/lib/sexplib0/sexp.ml` *) + Buffer.add_string b (Base.Sexp.Private.mach_maybe_esc_str s) + (* See how this is used in `_opam/lib/sexplib0/sexp.ml` *) | List [] -> Buffer.add_string b "()" | List (h :: t) -> - let is_partial = - match h with - | Atom "missing_type_conversion" when html -> true - | _ -> false - in - Buffer.add_char b '('; - if is_partial then Buffer.add_string b ""; - buffer h; - List.iter - (fun elt -> - Buffer.add_char b ' '; - buffer elt) - t; - if is_partial then Buffer.add_string b ""; - Buffer.add_char b ')' + let is_partial = + match h with + | Atom "missing_type_conversion" when html -> true + | _ -> false + in + Buffer.add_char b '('; + if is_partial then Buffer.add_string b ""; + buffer h; + List.iter + (fun elt -> + Buffer.add_char b ' '; + buffer elt) + t; + if is_partial then Buffer.add_string b ""; + Buffer.add_char b ')' in buffer +;; let buffer_mtype ?full ?human ?protect ?annot ~html b t = let s_expr = s_expression_of_mtype ?full ?human t in let s_expr = insert_field_annot annot s_expr in let sexp_to_string_flat = buffer_mtype_sexp ~html b in - match (protect, s_expr) with + match protect, s_expr with | None, List l -> Misc.buffer_concat b " " sexp_to_string_flat l | None, Atom a -> Buffer.add_string b (Base.Sexp.Private.mach_maybe_esc_str a) | Some (), any -> sexp_to_string_flat any +;; let string_of_mtype ?full ?human ?protect ?annot ~html t = - Misc.with_buffer (fun b -> - buffer_mtype ?full ?human ?protect ?annot ~html b t) + Misc.with_buffer (fun b -> buffer_mtype ?full ?human ?protect ?annot ~html b t) +;; let string_of_tparameter ~html (tparameter, annot) = string_of_mtype ~protect:() ~html ?annot tparameter +;; let memo_string_of_mtype_human = Misc.memoize ~clear_after:1000 (fun _f (full, se) -> - string_of_mtype - ?full:(if full then Some () else None) - ~human:() ~html:false se) + string_of_mtype ?full:(if full then Some () else None) ~human:() ~html:false se) +;; -let memo_string_of_mtype_human ?full t = - memo_string_of_mtype_human (full = Some (), t) +let memo_string_of_mtype_human ?full t = memo_string_of_mtype_human (full = Some (), t) let string_of_ok_stack ?full stack = String.concat " : " (List.map (memo_string_of_mtype_human ?full) stack) +;; let string_of_stack ?full = function | Stack_ok stack -> string_of_ok_stack ?full stack | Stack_failed -> "FAILED" +;; -let strip_annots {mt} = mk_mtype mt - -let strip_annot_variable {mt; annot_type} = mk_mtype mt ?annot_type +let strip_annots { mt } = mk_mtype mt +let strip_annot_variable { mt; annot_type } = mk_mtype mt ?annot_type (** {1 Stack helpers} *) -type tliteral = { - tliteral : (tinstr, tliteral) literal_f +type tliteral = + { tliteral : (tinstr, tliteral) literal_f ; t : mtype Result.t -} + } -and tinstr = { - tinstr : (tinstr, tliteral) instr_f +and tinstr = + { tinstr : (tinstr, tliteral) instr_f ; stack_in : stack Result.t ; stack_out : stack Result.t -} -[@@deriving eq, ord, show {with_path = false}] - -type ('i, 'l) talg = { - f_tinstr : - stack_in:stack Result.t - -> stack_out:stack Result.t - -> ('i, 'l) instr_f - -> 'i + } +[@@deriving eq, ord, show { with_path = false }] + +type ('i, 'l) talg = + { f_tinstr : + stack_in:stack Result.t -> stack_out:stack Result.t -> ('i, 'l) instr_f -> 'i ; f_tliteral : t:mtype Result.t -> ('i, 'l) literal_f -> 'l -} + } -let tcata {f_tinstr; f_tliteral} = - let rec cata_tinstr {tinstr; stack_in; stack_out} = +let tcata { f_tinstr; f_tliteral } = + let rec cata_tinstr { tinstr; stack_in; stack_out } = f_tinstr ~stack_in ~stack_out (map_instr_f cata_tinstr cata_tliteral tinstr) - and cata_tliteral {tliteral; t} = + and cata_tliteral { tliteral; t } = f_tliteral ~t (map_literal_f cata_tinstr cata_tliteral tliteral) in - (cata_tinstr, cata_tliteral) + cata_tinstr, cata_tliteral +;; let cata_tinstr alg = fst (tcata alg) - let cata_tliteral alg = snd (tcata alg) (* Paramorphisms on instructions and literals. *) let para_alg ~p_instr ~p_literal = - let f_instr i = ({instr = map_instr_f fst fst i}, p_instr i) in - let f_literal l = ({literal = map_literal_f fst fst l}, p_literal l) in - {f_instr; f_literal} + let f_instr i = { instr = map_instr_f fst fst i }, p_instr i in + let f_literal l = { literal = map_literal_f fst fst l }, p_literal l in + { f_instr; f_literal } +;; let _size_tinstr, _size_tliteral = let f_tinstr ~stack_in:_ ~stack_out:_ = fold_instr_f ( + ) ( + ) 1 in let f_tliteral ~t:_ = fold_literal_f ( + ) ( + ) 1 in - tcata {f_tinstr; f_tliteral} + tcata { f_tinstr; f_tliteral } +;; let erase_types_instr, erase_types_literal = - let f_tinstr ~stack_in:_ ~stack_out:_ instr = {instr} in - let f_tliteral ~t:_ literal = {literal} in - tcata {f_tinstr; f_tliteral} + let f_tinstr ~stack_in:_ ~stack_out:_ instr = { instr } in + let f_tliteral ~t:_ literal = { literal } in + tcata { f_tinstr; f_tliteral } +;; -type instr_spec = { - name : string +type instr_spec = + { name : string ; rule : - tparameter:mtype * string option + tparameter:mtype * string option -> mtype list -> (stack Result.t -> tinstr, mtype -> tliteral) instr_f -> (tinstr, tliteral) instr_f * stack Result.t ; commutative : bool ; arities : (int * int) option -} + } let mk_spec_raw name ?commutative ?arities rule = - {name; commutative = commutative = Some (); arities; rule} + { name; commutative = commutative = Some (); arities; rule } +;; let mk_spec name ?commutative ?arities rule = let rule ~tparameter stack instr = let err msg = let tinstr = - map_instr_f - (fun x -> x (Error (name ^ " error"))) - (fun _ -> assert false) - instr + map_instr_f (fun x -> x (Error (name ^ " error"))) (fun _ -> assert false) instr in - (tinstr, Error msg) + tinstr, Error msg in match rule ~tparameter stack instr with | Some x -> x | None -> err (name ^ ": unexpected stack") in - {name; commutative = commutative = Some (); arities; rule} + { name; commutative = commutative = Some (); arities; rule } +;; let mk_spec_no_sub name ?commutative ?arities rule = let rule ~tparameter stack instr = - let tinstr = - map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr - in + let tinstr = map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr in let stack = rule ~tparameter stack in Some (tinstr, stack) in mk_spec name ?commutative ?arities rule +;; let mk_spec_basic name ?commutative ~arities:(a_in, a_out) rule = let rule ~tparameter:_ stack instr = match rule stack with | None -> None | Some xs -> - assert (List.length xs = a_out); - let tinstr = - map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr - in - let stack = Ok (Stack_ok (xs @ List.drop a_in stack)) in - Some (tinstr, stack) + assert (List.length xs = a_out); + let tinstr = map_instr_f (fun _ -> assert false) (fun _ -> assert false) instr in + let stack = Ok (Stack_ok (xs @ List.drop a_in stack)) in + Some (tinstr, stack) in mk_spec name ?commutative ~arities:(a_in, a_out) rule +;; -let mk_spec_const name t = - mk_spec_basic ~arities:(0, 1) name (fun _ -> Some [t]) +let mk_spec_const name t = mk_spec_basic ~arities:(0, 1) name (fun _ -> Some [ t ]) (** {1 Unification} *) @@ -537,57 +515,62 @@ let unify_stack_elements t1 t2 = match unify_types ~tolerant:() t1 t2 with | Ok t -> Some t | Error _ -> None +;; let rec unify_ok_stacks s1 s2 = - match (s1, s2) with + match s1, s2 with | se1 :: s1, se2 :: s2 -> - Option.map2 - (fun x xs -> x :: xs) - (unify_stack_elements se1 se2) - (unify_ok_stacks s1 s2) + Option.map2 + (fun x xs -> x :: xs) + (unify_stack_elements se1 se2) + (unify_ok_stacks s1 s2) | [], [] -> Some [] | _ -> None +;; let unifiable_ok_stacks t u = Option.is_some (unify_ok_stacks t u) let unify_stacks s1 s2 = - match (s1, s2) with - | Stack_ok s1, Stack_ok s2 -> - Option.map (fun x -> Stack_ok x) (unify_ok_stacks s1 s2) + match s1, s2 with + | Stack_ok s1, Stack_ok s2 -> Option.map (fun x -> Stack_ok x) (unify_ok_stacks s1 s2) | Stack_failed, s2 -> Some s2 | s1, Stack_failed -> Some s1 +;; let initial_stack ~tparameter ~tstorage = Stack_ok - [ - mt_pair - {tparameter with annot_variable = Some "parameter"} - {tstorage with annot_variable = Some "storage"} + [ mt_pair + { tparameter with annot_variable = Some "parameter" } + { tstorage with annot_variable = Some "storage" } ] +;; (** {1 Michelson instructions} *) let mi_seq = let rule ~tparameter:_ stack = function | MIseq xs -> - let rec f r stack = function - | [] -> Some (MIseq (List.rev r), stack) - | x :: xs -> - let (x : tinstr) = x stack in - f (x :: r) x.stack_out xs - in - f [] (Ok (Stack_ok stack)) xs + let rec f r stack = function + | [] -> Some (MIseq (List.rev r), stack) + | x :: xs -> + let (x : tinstr) = x stack in + f (x :: r) x.stack_out xs + in + f [] (Ok (Stack_ok stack)) xs | _ -> assert false in mk_spec "(instruction sequence)" rule +;; let mi_comment = let rule ~tparameter:_ stack = Ok (Stack_ok stack) in mk_spec_no_sub "(comment instruction)" rule +;; let mi_error s = let rule ~tparameter:_ _stack = Error s in mk_spec_no_sub "(error instruction)" rule +;; let mi_failwith = let rule ~tparameter:_ = function @@ -595,159 +578,166 @@ let mi_failwith = | [] -> Error "FAILWITH on empty stack" in mk_spec_no_sub "FAILWITH" ~arities:(1, 0) rule +;; let mi_never = let rule ~tparameter:_ = function - | {mt = MT0 Never} :: _ -> Ok Stack_failed + | { mt = MT0 Never } :: _ -> Ok Stack_failed | _ -> Error "NEVER on empty stack" in mk_spec_no_sub "NEVER" ~arities:(1, 0) rule +;; let mi_ticket = mk_spec_basic "TICKET" ~arities:(2, 1) (function - | t :: {mt = MT0 Nat} :: _ -> Some [mt_option (mt_ticket t)] + | t :: { mt = MT0 Nat } :: _ -> Some [ mt_option (mt_ticket t) ] | _ -> None) +;; let mi_ticket_deprecated = mk_spec_basic "TICKET_DEPRECATED" ~arities:(2, 1) (function - | t :: {mt = MT0 Nat} :: _ -> Some [mt_ticket t] + | t :: { mt = MT0 Nat } :: _ -> Some [ mt_ticket t ] | _ -> None) +;; let mi_read_ticket = mk_spec_basic "READ_TICKET" ~arities:(1, 2) (function - | {mt = MT1 (Ticket, t)} :: _ -> - Some [mt_pair mt_address (mt_pair t mt_nat); mt_ticket t] + | { mt = MT1 (Ticket, t) } :: _ -> + Some [ mt_pair mt_address (mt_pair t mt_nat); mt_ticket t ] | _ -> None) +;; let mi_join_tickets = mk_spec_basic "JOIN_TICKETS" ~arities:(1, 1) (function - | { - mt = - MT2 - ( Pair _ - , ({mt = MT1 (Ticket, _)} as t1) - , ({mt = MT1 (Ticket, _)} as t2) ) + | { mt = + MT2 (Pair _, ({ mt = MT1 (Ticket, _) } as t1), ({ mt = MT1 (Ticket, _) } as t2)) } :: _ - when unifiable_types t1 t2 -> Some [mt_option t1] + when unifiable_types t1 t2 -> Some [ mt_option t1 ] | _ -> None) +;; let mi_split_ticket = mk_spec_basic "SPLIT_TICKET" ~arities:(2, 1) (function - | ({mt = MT1 (Ticket, _)} as t) - :: {mt = MT2 (Pair _, {mt = MT0 Nat}, {mt = MT0 Nat})} - :: _ -> Some [mt_option (mt_pair t t)] + | ({ mt = MT1 (Ticket, _) } as t) + :: { mt = MT2 (Pair _, { mt = MT0 Nat }, { mt = MT0 Nat }) } + :: _ -> Some [ mt_option (mt_pair t t) ] | _ -> None) +;; let mi_pairing_check = mk_spec_basic "PAIRING_CHECK" ~arities:(1, 1) (function - | { - mt = + | { mt = MT1 ( List - , { - mt = - MT2 (Pair _, {mt = MT0 Bls12_381_g1}, {mt = MT0 Bls12_381_g2}) - } ) + , { mt = MT2 (Pair _, { mt = MT0 Bls12_381_g1 }, { mt = MT0 Bls12_381_g2 }) } + ) } - :: _ -> Some [mt_bool] + :: _ -> Some [ mt_bool ] | _ -> None) +;; let cond_aux x y = let open Result in let* sx = x.stack_out in let* sy = y.stack_out in Option.cata (error "cannot unify branches") ok (unify_stacks sx sy) +;; let mi_if = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | {mt = MT0 Bool} :: tail, MIif (x, y) -> - let x = x (Ok (Stack_ok tail)) in - let y = y (Ok (Stack_ok tail)) in - Some (MIif (x, y), cond_aux x y) + match stack, instr with + | { mt = MT0 Bool } :: tail, MIif (x, y) -> + let x = x (Ok (Stack_ok tail)) in + let y = y (Ok (Stack_ok tail)) in + Some (MIif (x, y), cond_aux x y) | _, MIif _ -> None | _ -> assert false in mk_spec "IF" rule +;; let mi_if_none = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | {mt = MT1 (Option, t)} :: tail, MIif_none (x, y) -> - let a = - match t.annot_variable with - | Some v -> v ^ ".some" - | None -> "some" - in - let t = {t with annot_variable = Some a} in - let x = x (Ok (Stack_ok tail)) in - let y = y (Ok (Stack_ok (t :: tail))) in - Some (MIif_none (x, y), cond_aux x y) + match stack, instr with + | { mt = MT1 (Option, t) } :: tail, MIif_none (x, y) -> + let a = + match t.annot_variable with + | Some v -> v ^ ".some" + | None -> "some" + in + let t = { t with annot_variable = Some a } in + let x = x (Ok (Stack_ok tail)) in + let y = y (Ok (Stack_ok (t :: tail))) in + Some (MIif_none (x, y), cond_aux x y) | _, MIif_none _ -> None | _ -> assert false in mk_spec "IF_NONE" rule +;; let mi_if_left = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | ( {mt = MT2 (Or {annot_left; annot_right}, t, u); annot_variable} :: tail + match stack, instr with + | ( { mt = MT2 (Or { annot_left; annot_right }, t, u); annot_variable } :: tail , MIif_left (x, y) ) -> - let open Option in - let fa v = v ^ "." ^ Option.default "left" annot_left in - let t = {t with annot_variable = Option.map fa annot_variable} in - let fa v = v ^ "." ^ Option.default "right" annot_right in - let u = {u with annot_variable = Option.map fa annot_variable} in - let x = x (Ok (Stack_ok (t :: tail))) in - let y = y (Ok (Stack_ok (u :: tail))) in - return (MIif_left (x, y), cond_aux x y) + let open Option in + let fa v = v ^ "." ^ Option.default "left" annot_left in + let t = { t with annot_variable = Option.map fa annot_variable } in + let fa v = v ^ "." ^ Option.default "right" annot_right in + let u = { u with annot_variable = Option.map fa annot_variable } in + let x = x (Ok (Stack_ok (t :: tail))) in + let y = y (Ok (Stack_ok (u :: tail))) in + return (MIif_left (x, y), cond_aux x y) | _, MIif_left _ -> None | _ -> assert false in mk_spec "IF_LEFT" rule +;; let mi_if_cons = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | {mt = MT1 (List, t)} :: tail, MIif_cons (x, y) -> - let open Option in - let x = x (Ok (Stack_ok (t :: mt_list t :: tail))) in - let y = y (Ok (Stack_ok tail)) in - return (MIif_cons (x, y), cond_aux x y) + match stack, instr with + | { mt = MT1 (List, t) } :: tail, MIif_cons (x, y) -> + let open Option in + let x = x (Ok (Stack_ok (t :: mt_list t :: tail))) in + let y = y (Ok (Stack_ok tail)) in + return (MIif_cons (x, y), cond_aux x y) | _, MIif_cons _ -> None | _ -> assert false in mk_spec "IF_CONS" rule +;; let mi_dip = let rule ~tparameter:_ stack = function - | MIdip body -> ( - match stack with - | [] -> None - | t :: tail -> ( - let body = body (Ok (Stack_ok tail)) in - let tinstr = MIdip body in - match body.stack_out with - | Ok (Stack_ok tail') -> Some (tinstr, Ok (Stack_ok (t :: tail'))) - | _ -> Some (tinstr, Error "DIP: body error"))) + | MIdip body -> + (match stack with + | [] -> None + | t :: tail -> + let body = body (Ok (Stack_ok tail)) in + let tinstr = MIdip body in + (match body.stack_out with + | Ok (Stack_ok tail') -> Some (tinstr, Ok (Stack_ok (t :: tail'))) + | _ -> Some (tinstr, Error "DIP: body error"))) | _ -> assert false in mk_spec "DIP" rule +;; let mi_dipn = let rule ~tparameter:_ stack = function - | MIdipn (n, body) when n <= List.length stack -> ( - assert (n >= 0); - let body = body (Ok (Stack_ok (List.drop n stack))) in - let tinstr = MIdipn (n, body) in - match body.stack_out with - | Ok (Stack_ok stack') -> - Some (tinstr, Ok (Stack_ok (List.take n stack @ stack'))) - | _ -> Some (tinstr, Error "DIP: body error")) + | MIdipn (n, body) when n <= List.length stack -> + assert (n >= 0); + let body = body (Ok (Stack_ok (List.drop n stack))) in + let tinstr = MIdipn (n, body) in + (match body.stack_out with + | Ok (Stack_ok stack') -> Some (tinstr, Ok (Stack_ok (List.take n stack @ stack'))) + | _ -> Some (tinstr, Error "DIP: body error")) | _ -> assert false in mk_spec "DIPn" rule +;; let is_hot = let open Ternary in @@ -759,56 +749,62 @@ let is_hot = | t -> fold_mtype_f or_ No t in cata_mtype is_hot +;; let is_duppable t = is_hot t <> Yes let mi_dup i = assert (i >= 1); let rec get acc n = function - | x :: _ when n = 1 -> - if is_duppable x then Some (x :: List.rev (x :: acc)) else None + | x :: _ when n = 1 -> if is_duppable x then Some (x :: List.rev (x :: acc)) else None | x :: rest -> get (x :: acc) (n - 1) rest | [] -> None in mk_spec_basic "DUP" ~arities:(i, i + 1) (get [] i) +;; let mi_dig n = let rule ~tparameter:_ stack = match List.split_at_opt n stack with | None -> Error (sprintf "DIG %i: stack too short" n) - | Some (hi, lo) -> ( - match lo with - | [] -> Error (sprintf "DIG %i: stack too short" n) - | x :: lo -> Ok (Stack_ok ((x :: hi) @ lo))) + | Some (hi, lo) -> + (match lo with + | [] -> Error (sprintf "DIG %i: stack too short" n) + | x :: lo -> Ok (Stack_ok ((x :: hi) @ lo))) in mk_spec_no_sub "DIG" rule +;; let mi_dug n = let rule ~tparameter:_ = function | x :: tail -> - if n > List.length tail - then Error (sprintf "DUG %i: stack too short" n) - else - let hi, lo = List.split_at n tail in - Ok (Stack_ok (hi @ (x :: lo))) + if n > List.length tail + then Error (sprintf "DUG %i: stack too short" n) + else ( + let hi, lo = List.split_at n tail in + Ok (Stack_ok (hi @ (x :: lo)))) | [] -> Error "DUG: empty stack" in mk_spec_no_sub "DUG" rule +;; let mi_swap = mk_spec_basic "SWAP" ~arities:(2, 2) (function - | a :: b :: _ -> Some [b; a] + | a :: b :: _ -> Some [ b; a ] | _ -> None) +;; let mi_drop = mk_spec_basic "DROP" ~arities:(1, 0) (function | _ :: _ -> Some [] | [] -> None) +;; let mi_dropn n = mk_spec_basic "DROP" ~arities:(n, 0) (function | _ :: _ -> Some [] | [] -> None) +;; let unpair_size = List.fold_left (fun acc x -> acc + if x then 1 else 0) 0 @@ -816,247 +812,260 @@ let unpair_arg xs = if List.for_all id xs then string_of_int (List.length xs) else List.show String.pp (List.map string_of_bool xs) +;; let mi_unpair fields = assert (List.length fields >= 2); let rec aux acc fields stack = - match (stack, fields) with + match stack, fields with | _, [] -> Some (List.rev acc) - | _ :: _, [false] -> Some (List.rev acc) - | se :: _, [true] -> Some (List.rev (se :: acc)) - | {mt = MT2 (Pair _, fst, snd)} :: rest, select :: fields -> - let acc = if select then fst :: acc else acc in - aux acc fields (snd :: rest) + | _ :: _, [ false ] -> Some (List.rev acc) + | se :: _, [ true ] -> Some (List.rev (se :: acc)) + | { mt = MT2 (Pair _, fst, snd) } :: rest, select :: fields -> + let acc = if select then fst :: acc else acc in + aux acc fields (snd :: rest) | _ -> None in mk_spec_basic "UNPAIR" ~arities:(1, unpair_size fields) (aux [] fields) +;; let mi_pairn n = let rec aux acc n stack = if n = 0 - then + then ( let rec fold acc = function | x :: rest -> fold (mt_pair x acc) rest | [] -> acc in match acc with | [] -> None - | x :: rest -> Some [fold x rest] - else + | x :: rest -> Some [ fold x rest ]) + else ( match stack with | se :: rest -> aux (se :: acc) (n - 1) rest - | _ -> None + | _ -> None) in mk_spec_basic "PAIR" ~arities:(n, 1) (aux [] n) +;; let mi_iter = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | c :: tail, MIiter body -> ( - let el = - match c.mt with - | MT2 (Map, k, v) -> Some (mt_pair k v) - | MT1 ((List | Set), t) -> Some t - | _ -> None - in - match el with - | None -> None - | Some el -> - let body = body (Ok (Stack_ok (el :: tail))) in - let tinstr = MIiter body in - let ok = - match body.stack_out with - | Ok (Stack_ok stack') when unifiable_ok_stacks tail stack' -> - true - | Ok Stack_failed -> true - | _ -> false - in - let s = - if ok then Ok (Stack_ok tail) else Error "ITER: incompatible body" - in - Some (tinstr, s)) + match stack, instr with + | c :: tail, MIiter body -> + let el = + match c.mt with + | MT2 (Map, k, v) -> Some (mt_pair k v) + | MT1 ((List | Set), t) -> Some t + | _ -> None + in + (match el with + | None -> None + | Some el -> + let body = body (Ok (Stack_ok (el :: tail))) in + let tinstr = MIiter body in + let ok = + match body.stack_out with + | Ok (Stack_ok stack') when unifiable_ok_stacks tail stack' -> true + | Ok Stack_failed -> true + | _ -> false + in + let s = if ok then Ok (Stack_ok tail) else Error "ITER: incompatible body" in + Some (tinstr, s)) | [], MIiter _ -> None | _ -> assert false in mk_spec "ITER" rule +;; let mi_loop = let rule ~tparameter:_ stack = function - | MIloop body -> ( - match stack with - | {mt = MT0 Bool} :: tail -> ( - let body = body (Ok (Stack_ok tail)) in - let tinstr = MIloop body in - match body.stack_out with - | Ok (Stack_ok ({mt = MT0 Bool} :: tail')) - when unifiable_ok_stacks tail tail' -> - Some (tinstr, Ok (Stack_ok tail)) - | _ -> Some (tinstr, Error "LOOP: incompatible body")) - | _ -> None) + | MIloop body -> + (match stack with + | { mt = MT0 Bool } :: tail -> + let body = body (Ok (Stack_ok tail)) in + let tinstr = MIloop body in + (match body.stack_out with + | Ok (Stack_ok ({ mt = MT0 Bool } :: tail')) when unifiable_ok_stacks tail tail' + -> Some (tinstr, Ok (Stack_ok tail)) + | _ -> Some (tinstr, Error "LOOP: incompatible body")) + | _ -> None) | _ -> assert false in mk_spec "LOOP" rule +;; let mi_loop_left = let rule ~tparameter:_ stack = function - | MIloop_left body -> ( - match stack with - | {mt = MT2 (Or _, a, b)} :: tail -> ( - let body = body (Ok (Stack_ok (a :: tail))) in - let tinstr = MIloop_left body in - match body.stack_out with - | Ok (Stack_ok ({mt = MT2 (Pair _, a', b')} :: tail')) - when unifiable_types a a' && unifiable_types b b' - && unifiable_ok_stacks tail tail' -> - Some (tinstr, Ok (Stack_ok (b :: tail))) - | _ -> Some (tinstr, Error "LOOP_LEFT: incompatible body")) - | _ -> None) + | MIloop_left body -> + (match stack with + | { mt = MT2 (Or _, a, b) } :: tail -> + let body = body (Ok (Stack_ok (a :: tail))) in + let tinstr = MIloop_left body in + (match body.stack_out with + | Ok (Stack_ok ({ mt = MT2 (Pair _, a', b') } :: tail')) + when unifiable_types a a' + && unifiable_types b b' + && unifiable_ok_stacks tail tail' -> + Some (tinstr, Ok (Stack_ok (b :: tail))) + | _ -> Some (tinstr, Error "LOOP_LEFT: incompatible body")) + | _ -> None) | _ -> assert false in mk_spec "LOOP_LEFT" rule +;; let mi_lambda = let rule ~tparameter:_ stack = function | MIlambda (t_in, t_out, body) -> - let body = body (Ok (Stack_ok [t_in])) in - let tinstr = MIlambda (t_in, t_out, body) in - let stack = - let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in - match body.stack_out with - | Ok (Stack_ok [t_out']) when unifiable_types t_out t_out' -> ok - | Ok (Stack_ok _) -> Error "LAMBDA: non-singleton result stack" - | Ok Stack_failed -> ok - | Error s -> Error (Printf.sprintf "lambda stack error %s" s) - in - (tinstr, stack) + let body = body (Ok (Stack_ok [ t_in ])) in + let tinstr = MIlambda (t_in, t_out, body) in + let stack = + let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in + match body.stack_out with + | Ok (Stack_ok [ t_out' ]) when unifiable_types t_out t_out' -> ok + | Ok (Stack_ok _) -> Error "LAMBDA: non-singleton result stack" + | Ok Stack_failed -> ok + | Error s -> Error (Printf.sprintf "lambda stack error %s" s) + in + tinstr, stack | _ -> assert false in mk_spec_raw "LAMBDA" rule +;; let mi_lambda_rec = let rule ~tparameter:_ stack = function | MIlambda_rec (t_in, t_out, body) -> - let body = body (Ok (Stack_ok [t_in; mt_lambda t_in t_out])) in - let tinstr = MIlambda_rec (t_in, t_out, body) in - let stack = - let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in - match body.stack_out with - | Ok (Stack_ok [t_out']) when unifiable_types t_out t_out' -> ok - | Ok (Stack_ok _) -> Error "LAMBDA_REC: non-singleton result stack" - | Ok Stack_failed -> ok - | Error s -> Error (Printf.sprintf "lambda_rec stack error %s" s) - in - (tinstr, stack) + let body = body (Ok (Stack_ok [ t_in; mt_lambda t_in t_out ])) in + let tinstr = MIlambda_rec (t_in, t_out, body) in + let stack = + let ok = Ok (Stack_ok (mt_lambda t_in t_out :: stack)) in + match body.stack_out with + | Ok (Stack_ok [ t_out' ]) when unifiable_types t_out t_out' -> ok + | Ok (Stack_ok _) -> Error "LAMBDA_REC: non-singleton result stack" + | Ok Stack_failed -> ok + | Error s -> Error (Printf.sprintf "lambda_rec stack error %s" s) + in + tinstr, stack | _ -> assert false in mk_spec_raw "LAMBDA_REC" rule +;; let mi_map = let rule ~tparameter:_ stack instr = - match (stack, instr) with - | c :: tail, MImap body -> ( - let wrap_v = - match c.mt with - | MT2 (Map, k, v) -> Some (mt_map k, mt_pair k v) - | MT1 (List, v) -> Some (mt_list, v) - | MT1 (Option, v) -> Some (mt_option, v) - | _ -> None - in - match wrap_v with - | None -> None - | Some (wrap, v) -> ( - let body = body (Ok (Stack_ok (v :: tail))) in - let tinstr = MImap body in - match body.stack_out with - | Ok (Stack_ok (v' :: tail')) when unifiable_ok_stacks tail tail' -> - Some (tinstr, Ok (Stack_ok (wrap v' :: tail))) - | _ -> Some (tinstr, Error "MAP: incompatible body"))) + match stack, instr with + | c :: tail, MImap body -> + let wrap_v = + match c.mt with + | MT2 (Map, k, v) -> Some (mt_map k, mt_pair k v) + | MT1 (List, v) -> Some (mt_list, v) + | MT1 (Option, v) -> Some (mt_option, v) + | _ -> None + in + (match wrap_v with + | None -> None + | Some (wrap, v) -> + let body = body (Ok (Stack_ok (v :: tail))) in + let tinstr = MImap body in + (match body.stack_out with + | Ok (Stack_ok (v' :: tail')) when unifiable_ok_stacks tail tail' -> + Some (tinstr, Ok (Stack_ok (wrap v' :: tail))) + | _ -> Some (tinstr, Error "MAP: incompatible body"))) | [], MImap _ -> None | _ -> assert false in mk_spec "MAP" rule +;; let mi_pair ?annot_fst ?annot_snd () = mk_spec_basic "PAIR" ~arities:(2, 1) (function - | a :: b :: _ -> Some [mt_pair ?annot_fst ?annot_snd a b] + | a :: b :: _ -> Some [ mt_pair ?annot_fst ?annot_snd a b ] | _ -> None) +;; let mi_cons = mk_spec_basic "CONS" ~arities:(2, 1) (function - | a :: {mt = MT1 (List, a')} :: _ -> ( - match unify_types ~tolerant:() a a' with - | Ok t -> Some [mt_list (strip_annots t)] - | Error _ -> None) + | a :: { mt = MT1 (List, a') } :: _ -> + (match unify_types ~tolerant:() a a' with + | Ok t -> Some [ mt_list (strip_annots t) ] + | Error _ -> None) | _ -> None) +;; let mi_get = mk_spec_basic "GET" ~arities:(2, 1) (function - | key :: {mt = MT2 (Map, key', value)} :: _ when unifiable_types key key' -> - Some [mt_option value] - | key :: {mt = MT2 (Big_map, key', value)} :: _ - when unifiable_types key key' -> Some [mt_option value] + | key :: { mt = MT2 (Map, key', value) } :: _ when unifiable_types key key' -> + Some [ mt_option value ] + | key :: { mt = MT2 (Big_map, key', value) } :: _ when unifiable_types key key' -> + Some [ mt_option value ] | _ -> None) +;; let rec get_comb_type n = function | t when n = 0 -> Some t - | {mt = MT2 (Pair _, fst, _)} when n = 1 -> Some fst - | {mt = MT2 (Pair _, _, snd)} -> get_comb_type (n - 2) snd + | { mt = MT2 (Pair _, fst, _) } when n = 1 -> Some fst + | { mt = MT2 (Pair _, _, snd) } -> get_comb_type (n - 2) snd | _ -> None +;; let mi_getn n = mk_spec_basic "GET" ~arities:(1, 1) (function - | t :: _ -> Option.map (fun t -> [t]) (get_comb_type n t) + | t :: _ -> Option.map (fun t -> [ t ]) (get_comb_type n t) | [] -> None) +;; let mi_updaten n = mk_spec_basic "UPDATE" ~arities:(2, 1) (function - | t1 :: t :: _ -> ( - match get_comb_type n t with - | None -> None - | Some t2 -> if unifiable_types t1 t2 then Some [t] else None) + | t1 :: t :: _ -> + (match get_comb_type n t with + | None -> None + | Some t2 -> if unifiable_types t1 t2 then Some [ t ] else None) | _ :: _ | [] -> None) +;; let mi_eq = mk_spec_basic "EQ" ~commutative:() ~arities:(1, 1) (function - | {mt = MT0 Int} :: _ -> Some [mt_bool] + | { mt = MT0 Int } :: _ -> Some [ mt_bool ] | _ -> None) +;; -let mi_neq = {mi_eq with name = "NEQ"} - -let mi_lt = {mi_neq with name = "LT"; commutative = false} - -let mi_le = {mi_lt with name = "LE"} - -let mi_gt = {mi_lt with name = "GT"} - -let mi_ge = {mi_lt with name = "GE"} +let mi_neq = { mi_eq with name = "NEQ" } +let mi_lt = { mi_neq with name = "LT"; commutative = false } +let mi_le = { mi_lt with name = "LE" } +let mi_gt = { mi_lt with name = "GT" } +let mi_ge = { mi_lt with name = "GE" } let mi_neg = mk_spec_basic "NEG" ~arities:(1, 1) (function - | {mt = MT0 Nat} :: _ -> Some [mt_int] - | {mt = MT0 Int} :: _ -> Some [mt_int] - | {mt = MT0 Bls12_381_g1} :: _ -> Some [mt_bls12_381_g1] - | {mt = MT0 Bls12_381_g2} :: _ -> Some [mt_bls12_381_g2] - | {mt = MT0 Bls12_381_fr} :: _ -> Some [mt_bls12_381_fr] + | { mt = MT0 Nat } :: _ -> Some [ mt_int ] + | { mt = MT0 Int } :: _ -> Some [ mt_int ] + | { mt = MT0 Bls12_381_g1 } :: _ -> Some [ mt_bls12_381_g1 ] + | { mt = MT0 Bls12_381_g2 } :: _ -> Some [ mt_bls12_381_g2 ] + | { mt = MT0 Bls12_381_fr } :: _ -> Some [ mt_bls12_381_fr ] | _ -> None) +;; let mi_int = mk_spec_basic "INT" ~arities:(1, 1) (function - | {mt = MT0 Bytes} :: _ -> Some [mt_int] - | {mt = MT0 Nat} :: _ -> Some [mt_int] - | {mt = MT0 Bls12_381_fr} :: _ -> Some [mt_int] + | { mt = MT0 Bytes } :: _ -> Some [ mt_int ] + | { mt = MT0 Nat } :: _ -> Some [ mt_int ] + | { mt = MT0 Bls12_381_fr } :: _ -> Some [ mt_int ] | _ -> None) +;; let mi_nat = mk_spec_basic "NAT" ~arities:(1, 1) (function - | {mt = MT0 Bytes} :: _ -> Some [mt_nat] + | { mt = MT0 Bytes } :: _ -> Some [ mt_nat ] | _ -> None) +;; let mi_bytes = mk_spec_basic "BYTES" ~arities:(1, 1) (function - | {mt = MT0 Int} :: _ -> Some [mt_bytes] - | {mt = MT0 Nat} :: _ -> Some [mt_bytes] + | { mt = MT0 Int } :: _ -> Some [ mt_bytes ] + | { mt = MT0 Nat } :: _ -> Some [ mt_bytes ] | _ -> None) +;; let rec is_comparable mtype = match mtype.mt with @@ -1076,8 +1085,7 @@ let rec is_comparable mtype = | Signature | Never ) -> true | MT1 (Option, t) -> is_comparable t - | MT2 (Pair _, t1, t2) | MT2 (Or _, t1, t2) -> - is_comparable t1 && is_comparable t2 + | MT2 (Pair _, t1, t2) | MT2 (Or _, t1, t2) -> is_comparable t1 && is_comparable t2 | MT0 ( Operation | Sapling_state _ @@ -1090,83 +1098,85 @@ let rec is_comparable mtype = | MT1 ((List | Set | Contract | Ticket), _) | MT2 ((Lambda | Map | Big_map), _, _) | MT_var _ -> false +;; let mi_compare = mk_spec_basic "COMPARE" ~arities:(2, 1) (function - | a :: b :: _ when is_comparable a && is_comparable b && unifiable_types a b - -> Some [mt_int] + | a :: b :: _ when is_comparable a && is_comparable b && unifiable_types a b -> + Some [ mt_int ] | _ -> None) +;; let mi_sub = mk_spec_basic "SUB" ~arities:(2, 1) (function - | {mt = MT0 Int} :: {mt = MT0 Int} :: _ -> Some [mt_int] - | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> Some [mt_int] - | {mt = MT0 Nat} :: {mt = MT0 Int} :: _ -> Some [mt_int] - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_int] - | {mt = MT0 Mutez} :: {mt = MT0 Mutez} :: _ -> Some [mt_mutez] - | {mt = MT0 Timestamp} :: {mt = MT0 Int} :: _ -> Some [mt_timestamp] - | {mt = MT0 Timestamp} :: {mt = MT0 Timestamp} :: _ -> Some [mt_int] + | { mt = MT0 Int } :: { mt = MT0 Int } :: _ -> Some [ mt_int ] + | { mt = MT0 Int } :: { mt = MT0 Nat } :: _ -> Some [ mt_int ] + | { mt = MT0 Nat } :: { mt = MT0 Int } :: _ -> Some [ mt_int ] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: _ -> Some [ mt_int ] + | { mt = MT0 Mutez } :: { mt = MT0 Mutez } :: _ -> Some [ mt_mutez ] + | { mt = MT0 Timestamp } :: { mt = MT0 Int } :: _ -> Some [ mt_timestamp ] + | { mt = MT0 Timestamp } :: { mt = MT0 Timestamp } :: _ -> Some [ mt_int ] | _ -> None) +;; let mi_ediv = mk_spec_basic "EDIV" ~arities:(2, 1) (function - | {mt = MT0 Int} :: {mt = MT0 Int} :: _ -> - Some [mt_option (mt_pair mt_int mt_nat)] - | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> - Some [mt_option (mt_pair mt_int mt_nat)] - | {mt = MT0 Nat} :: {mt = MT0 Int} :: _ -> - Some [mt_option (mt_pair mt_int mt_nat)] - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> - Some [mt_option (mt_pair mt_nat mt_nat)] - | {mt = MT0 Mutez} :: {mt = MT0 Nat} :: _ -> - Some [mt_option (mt_pair mt_mutez mt_mutez)] - | {mt = MT0 Mutez} :: {mt = MT0 Mutez} :: _ -> - Some [mt_option (mt_pair mt_nat mt_mutez)] + | { mt = MT0 Int } :: { mt = MT0 Int } :: _ -> + Some [ mt_option (mt_pair mt_int mt_nat) ] + | { mt = MT0 Int } :: { mt = MT0 Nat } :: _ -> + Some [ mt_option (mt_pair mt_int mt_nat) ] + | { mt = MT0 Nat } :: { mt = MT0 Int } :: _ -> + Some [ mt_option (mt_pair mt_int mt_nat) ] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: _ -> + Some [ mt_option (mt_pair mt_nat mt_nat) ] + | { mt = MT0 Mutez } :: { mt = MT0 Nat } :: _ -> + Some [ mt_option (mt_pair mt_mutez mt_mutez) ] + | { mt = MT0 Mutez } :: { mt = MT0 Mutez } :: _ -> + Some [ mt_option (mt_pair mt_nat mt_mutez) ] | _ -> None) +;; let mi_not ~protocol:_ = mk_spec_basic "NOT" ~commutative:() ~arities:(1, 1) (function - | {mt = MT0 Bool} :: _ -> Some [mt_bool] - | {mt = MT0 Nat} :: _ -> Some [mt_int] - | {mt = MT0 Int} :: _ -> Some [mt_int] - | {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | { mt = MT0 Bool } :: _ -> Some [ mt_bool ] + | { mt = MT0 Nat } :: _ -> Some [ mt_int ] + | { mt = MT0 Int } :: _ -> Some [ mt_int ] + | { mt = MT0 Bytes } :: _ -> Some [ mt_bytes ] | _ -> None) +;; let mi_and ~protocol:_ = mk_spec_basic "AND" ~commutative:() ~arities:(2, 1) (function - | {mt = MT0 Bool} :: {mt = MT0 Bool} :: _ -> Some [mt_bool] - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] - | {mt = MT0 Int} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] - | {mt = MT0 Bytes} :: {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | { mt = MT0 Bool } :: { mt = MT0 Bool } :: _ -> Some [ mt_bool ] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: _ -> Some [ mt_nat ] + | { mt = MT0 Int } :: { mt = MT0 Nat } :: _ -> Some [ mt_nat ] + | { mt = MT0 Bytes } :: { mt = MT0 Bytes } :: _ -> Some [ mt_bytes ] | _ -> None) +;; let mi_or ~protocol:_ = mk_spec_basic "OR" ~commutative:() ~arities:(2, 1) (function - | {mt = MT0 Bool} :: {mt = MT0 Bool} :: _ -> Some [mt_bool] - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] - | {mt = MT0 Bytes} :: {mt = MT0 Bytes} :: _ -> Some [mt_bytes] + | { mt = MT0 Bool } :: { mt = MT0 Bool } :: _ -> Some [ mt_bool ] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: _ -> Some [ mt_nat ] + | { mt = MT0 Bytes } :: { mt = MT0 Bytes } :: _ -> Some [ mt_bytes ] | _ -> None) +;; -let mi_xor ~protocol = {(mi_or ~protocol) with name = "XOR"} +let mi_xor ~protocol = { (mi_or ~protocol) with name = "XOR" } let mi_shift_left ~protocol:_ = mk_spec_basic "LSL" ~arities:(2, 1) (function - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: _ -> Some [mt_nat] - | {mt = MT0 Bytes} :: {mt = MT0 Nat} :: _ -> Some [mt_bytes] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: _ -> Some [ mt_nat ] + | { mt = MT0 Bytes } :: { mt = MT0 Nat } :: _ -> Some [ mt_bytes ] | _ -> None) +;; -let mi_shift_right ~protocol = {(mi_shift_left ~protocol) with name = "LSR"} - +let mi_shift_right ~protocol = { (mi_shift_left ~protocol) with name = "LSR" } let mi_unit = mk_spec_const "UNIT" mt_unit - let mi_nil t = mk_spec_const "NIL" (mt_list t) - let mi_empty_set t = mk_spec_const "EMPTY_SET" (mt_set t) - let mi_empty_map k v = mk_spec_const "EMPTY_MAP" (mt_map k v) - let mi_empty_big_map k v = mk_spec_const "EMPTY_BIG_MAP" (mt_big_map k v) - let mi_none t = mk_spec_const "NONE" (mt_option t) let is_pushable t = @@ -1204,141 +1214,157 @@ let is_pushable t = | MT2 (Pair _, _, _) | MT2 (Or _, _, _) -> true | MT_var _ -> false +;; let mi_push = let rule ~tparameter:_ stack = function | MIpush (t, l) -> - let l = l t in - let tinstr = MIpush (t, l) in - let stack = - if is_pushable t - then - match l.t with - | Ok _ -> Ok (Stack_ok (t :: stack)) - | Error e -> Error e - else Error "Type is not pushable" - in - (tinstr, stack) + let l = l t in + let tinstr = MIpush (t, l) in + let stack = + if is_pushable t + then ( + match l.t with + | Ok _ -> Ok (Stack_ok (t :: stack)) + | Error e -> Error e) + else Error "Type is not pushable" + in + tinstr, stack | _ -> assert false in mk_spec_raw "PUSH" ~arities:(0, 1) rule +;; let mi_some = mk_spec_basic "SOME" ~arities:(1, 1) (function - | t :: _ -> Some [mt_option (strip_annots t)] + | t :: _ -> Some [ mt_option (strip_annots t) ] | [] -> None) +;; let mi_left ?annot_left ?annot_right b = mk_spec_basic "LEFT" ~arities:(1, 1) (function - | a :: _ -> Some [mt_or ?annot_left ?annot_right (strip_annots a) b] + | a :: _ -> Some [ mt_or ?annot_left ?annot_right (strip_annots a) b ] | [] -> None) +;; let mi_right ?annot_left ?annot_right a = mk_spec_basic "RIGHT" ~arities:(1, 1) (function - | b :: _ -> Some [mt_or ?annot_left ?annot_right a (strip_annots b)] + | b :: _ -> Some [ mt_or ?annot_left ?annot_right a (strip_annots b) ] | [] -> None) +;; (** Select the part of the type designated by the ad_path. *) let rec ad_path_in_type ops t = - match (ops, t) with + match ops, t with | [], _ -> Some t - | A :: p, {mt = MT2 (Pair _, fst, _)} -> ad_path_in_type p fst - | D :: p, {mt = MT2 (Pair _, _, snd)} -> ad_path_in_type p snd + | A :: p, { mt = MT2 (Pair _, fst, _) } -> ad_path_in_type p fst + | D :: p, { mt = MT2 (Pair _, _, snd) } -> ad_path_in_type p snd | _ :: _, _ -> None +;; let mi_field steps = - mk_spec_basic ~arities:(1, 1) + mk_spec_basic + ~arities:(1, 1) (sprintf "C%sR" (string_of_ad_path steps)) (function - | t :: _ -> ( - match ad_path_in_type steps t with - | None -> None - | Some t -> Some [t]) - | [] -> None) + | t :: _ -> + (match ad_path_in_type steps t with + | None -> None + | Some t -> Some [ t ]) + | [] -> None) +;; let mi_set_field steps = - mk_spec_basic ~arities:(2, 1) + mk_spec_basic + ~arities:(2, 1) (sprintf "SET_C%sR" (string_of_ad_path steps)) (function - | t :: x :: _ -> ( - match ad_path_in_type steps t with - | Some x' when unifiable_types x x' -> Some [t] - | _ -> None) - | _ -> None) + | t :: x :: _ -> + (match ad_path_in_type steps t with + | Some x' when unifiable_types x x' -> Some [ t ] + | _ -> None) + | _ -> None) +;; let mi_update = mk_spec_basic "UPDATE" ~arities:(3, 1) (function - | k :: {mt = MT0 Bool} :: {mt = MT1 (Set, k')} :: _ -> - Option.map - (fun k -> [mt_set k]) - (Result.get_ok (unify_types ~tolerant:() k k')) - | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Map, k', v')} :: _ -> - Option.map2 - (fun k v -> [mt_map k v]) - (Result.get_ok (unify_types ~tolerant:() k k')) - (Result.get_ok (unify_types ~tolerant:() v v')) - | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Big_map, k', v')} :: _ -> - Option.map2 - (fun k v -> [mt_big_map k v]) - (Result.get_ok (unify_types ~tolerant:() k k')) - (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: { mt = MT0 Bool } :: { mt = MT1 (Set, k') } :: _ -> + Option.map (fun k -> [ mt_set k ]) (Result.get_ok (unify_types ~tolerant:() k k')) + | k :: { mt = MT1 (Option, v) } :: { mt = MT2 (Map, k', v') } :: _ -> + Option.map2 + (fun k v -> [ mt_map k v ]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: { mt = MT1 (Option, v) } :: { mt = MT2 (Big_map, k', v') } :: _ -> + Option.map2 + (fun k v -> [ mt_big_map k v ]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) | _ -> None) +;; let mi_get_and_update = mk_spec_basic "GET_AND_UPDATE" ~arities:(3, 2) (function - | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Map, k', v')} :: _ -> - Option.map2 - (fun k v -> [mt_option v; mt_map k v]) - (Result.get_ok (unify_types ~tolerant:() k k')) - (Result.get_ok (unify_types ~tolerant:() v v')) - | k :: {mt = MT1 (Option, v)} :: {mt = MT2 (Big_map, k', v')} :: _ -> - Option.map2 - (fun k v -> [mt_option v; mt_big_map k v]) - (Result.get_ok (unify_types ~tolerant:() k k')) - (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: { mt = MT1 (Option, v) } :: { mt = MT2 (Map, k', v') } :: _ -> + Option.map2 + (fun k v -> [ mt_option v; mt_map k v ]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) + | k :: { mt = MT1 (Option, v) } :: { mt = MT2 (Big_map, k', v') } :: _ -> + Option.map2 + (fun k v -> [ mt_option v; mt_big_map k v ]) + (Result.get_ok (unify_types ~tolerant:() k k')) + (Result.get_ok (unify_types ~tolerant:() v v')) | _ -> None) +;; let mi_open_chest = mk_spec_basic "OPEN_CHEST" ~arities:(3, 1) (function - | {mt = MT0 Chest_key} :: {mt = MT0 Chest} :: {mt = MT0 Nat} :: _ -> - Some [mt_or mt_bytes mt_bool] + | { mt = MT0 Chest_key } :: { mt = MT0 Chest } :: { mt = MT0 Nat } :: _ -> + Some [ mt_or mt_bytes mt_bool ] | _ -> None) +;; let mi_mem = mk_spec_basic "MEM" ~arities:(2, 1) (function - | k :: {mt = MT1 (Set, k')} :: _ when unifiable_types k k' -> Some [mt_bool] - | k :: {mt = MT2 (Map, k', _)} :: _ when unifiable_types k k' -> - Some [mt_bool] - | k :: {mt = MT2 (Big_map, k', _)} :: _ when unifiable_types k k' -> - Some [mt_bool] + | k :: { mt = MT1 (Set, k') } :: _ when unifiable_types k k' -> Some [ mt_bool ] + | k :: { mt = MT2 (Map, k', _) } :: _ when unifiable_types k k' -> Some [ mt_bool ] + | k :: { mt = MT2 (Big_map, k', _) } :: _ when unifiable_types k k' -> + Some [ mt_bool ] | _ -> None) +;; let mi_exec = mk_spec_basic "EXEC" ~arities:(2, 1) (function - | k :: {mt = MT2 (Lambda, k', v)} :: _ -> - if unifiable_types k k' then Some [v] else None + | k :: { mt = MT2 (Lambda, k', v) } :: _ -> + if unifiable_types k k' then Some [ v ] else None | _ -> None) +;; let mi_apply = mk_spec_basic "APPLY" ~arities:(2, 1) (function - | k :: {mt = MT2 (Lambda, {mt = MT2 (Pair _, k', k'')}, v)} :: _ - when unifiable_types k k' -> Some [mt_lambda k'' v] + | k :: { mt = MT2 (Lambda, { mt = MT2 (Pair _, k', k'') }, v) } :: _ + when unifiable_types k k' -> Some [ mt_lambda k'' v ] | _ -> None) +;; let mi_contract t = mk_spec_basic "CONTRACT" ~arities:(1, 1) (function - | {mt = MT0 Address} :: _ -> Some [mt_option (mt_contract t)] + | { mt = MT0 Address } :: _ -> Some [ mt_option (mt_contract t) ] | _ -> None) +;; let mi_view t = mk_spec_basic "VIEW" ~arities:(2, 1) (function - | _ :: {mt = MT0 Address} :: _ -> Some [mt_option t] + | _ :: { mt = MT0 Address } :: _ -> Some [ mt_option t ] | _ -> None) +;; let mi_cast t = mk_spec_basic "CAST" ~arities:(1, 1) (function - | t' :: _ when unifiable_types t t' -> Some [t] + | t' :: _ when unifiable_types t t' -> Some [ t ] | _ -> None) +;; let mi_emit t = let matches t' = @@ -1347,180 +1373,187 @@ let mi_emit t = | Some t -> unifiable_types t t' in mk_spec_basic "EMIT" ~arities:(1, 1) (function - | t' :: _ when matches t' -> Some [mt_operation] + | t' :: _ when matches t' -> Some [ mt_operation ] | _ -> None) +;; let mi_rename annot_variable = mk_spec_basic "RENAME" ~arities:(1, 1) (function - | t :: _ -> Some [{t with annot_variable}] + | t :: _ -> Some [ { t with annot_variable } ] | _ -> None) +;; let mi_transfer_tokens = mk_spec_basic "TRANSFER_TOKENS" ~arities:(3, 1) (function - | p :: {mt = MT0 Mutez} :: {mt = MT1 (Contract, p')} :: _ - when unifiable_types p p' -> Some [mt_operation] + | p :: { mt = MT0 Mutez } :: { mt = MT1 (Contract, p') } :: _ + when unifiable_types p p' -> Some [ mt_operation ] | _ -> None) +;; let mi_set_delegate = mk_spec_basic "SET_DELEGATE" ~arities:(1, 1) (function - | {mt = MT1 (Option, {mt = MT0 Key_hash})} :: _ -> Some [mt_operation] + | { mt = MT1 (Option, { mt = MT0 Key_hash }) } :: _ -> Some [ mt_operation ] | _ -> None) +;; let mi_sapling_verify_update = mk_spec_basic "SAPLING_VERIFY_UPDATE" ~arities:(2, 1) (function - | {mt = MT0 (Sapling_transaction {memo = m1})} - :: {mt = MT0 (Sapling_state {memo = m2})} + | { mt = MT0 (Sapling_transaction { memo = m1 }) } + :: { mt = MT0 (Sapling_state { memo = m2 }) } :: _ when m1 = m2 -> - Some - [mt_option (mt_pair mt_bytes (mt_pair mt_int (mt_sapling_state m1)))] + Some [ mt_option (mt_pair mt_bytes (mt_pair mt_int (mt_sapling_state m1))) ] | _ -> None) +;; let mi_concat1 = mk_spec_basic "CONCAT" ~arities:(1, 1) (function - | {mt = MT1 (List, {mt = MT0 (String | Bytes) as mt})} :: _ -> - Some [mk_mtype mt] + | { mt = MT1 (List, { mt = MT0 (String | Bytes) as mt }) } :: _ -> + Some [ mk_mtype mt ] | _ -> None) +;; let mi_concat2 = mk_spec_basic "CONCAT" ~arities:(2, 1) (function - | {mt = MT0 String as mt} :: {mt = MT0 String} :: _ - | {mt = MT0 Bytes as mt} :: {mt = MT0 Bytes} :: _ -> Some [mk_mtype mt] + | { mt = MT0 String as mt } :: { mt = MT0 String } :: _ + | { mt = MT0 Bytes as mt } :: { mt = MT0 Bytes } :: _ -> Some [ mk_mtype mt ] | _ -> None) +;; let mi_concat_unresolved = let rule ~tparameter stack instr = let _instr1, r1 = mi_concat1.rule ~tparameter stack instr in match r1 with - | Ok _ -> (MI1 Concat1, r1) + | Ok _ -> MI1 Concat1, r1 | Error _ -> - let _instr2, r2 = mi_concat2.rule ~tparameter stack instr in - (MI2 Concat2, r2) + let _instr2, r2 = mi_concat2.rule ~tparameter stack instr in + MI2 Concat2, r2 in - {name = "CONCAT"; rule; commutative = false; arities = None} + { name = "CONCAT"; rule; commutative = false; arities = None } +;; let mi_pack = mk_spec_basic "PACK" ~arities:(1, 1) (function - | t :: _ when is_packable t -> Some [mt_bytes] + | t :: _ when is_packable t -> Some [ mt_bytes ] | _ -> None) +;; let mi_unpack t = mk_spec_basic "UNPACK" ~arities:(1, 1) (function - | {mt = MT0 Bytes} :: _ when is_packable t -> Some [mt_option t] + | { mt = MT0 Bytes } :: _ when is_packable t -> Some [ mt_option t ] | _ -> None) +;; let mi_slice = mk_spec_basic "SLICE" ~arities:(3, 1) (function - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: {mt = MT0 String} :: _ -> - Some [mt_option mt_string] - | {mt = MT0 Nat} :: {mt = MT0 Nat} :: {mt = MT0 Bytes} :: _ -> - Some [mt_option mt_bytes] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: { mt = MT0 String } :: _ -> + Some [ mt_option mt_string ] + | { mt = MT0 Nat } :: { mt = MT0 Nat } :: { mt = MT0 Bytes } :: _ -> + Some [ mt_option mt_bytes ] | _ -> None) +;; let mi_size = mk_spec_basic "SIZE" ~arities:(1, 1) (function - | { - mt = - ( MT0 String - | MT0 Bytes - | MT1 ((Set | List), _) - | MT2 ((Map | Big_map), _, _) ) + | { mt = MT0 String | MT0 Bytes | MT1 ((Set | List), _) | MT2 ((Map | Big_map), _, _) } - :: _ -> Some [mt_nat] + :: _ -> Some [ mt_nat ] | _ -> None) +;; let mi_mich ~name ~types_in ~types_out = - mk_spec_basic name + mk_spec_basic + name ~arities:(List.length types_in, List.length types_out) (fun stack -> if List.is_prefix equal_mtype types_in stack then Some types_out else None) +;; let mi_self = let rule ~tparameter stack = function - | MI0 (Self ep_name) -> ( - let tinstr = MI0 (Self ep_name) in - let mt_contract t = - {(mt_contract t) with annot_variable = Some "self"} - in - match ep_name with - | None -> - Some (tinstr, Ok (Stack_ok (mt_contract (fst tparameter) :: stack))) - | Some ep_name -> ( - let rec find_ep (t, annot) = - match (t.mt, annot) with - | _, Some a when a = ep_name -> Some t - | MT2 (Or {annot_left; annot_right}, left, right), None -> ( - match find_ep (left, annot_left) with - | Some t -> Some t - | None -> find_ep (right, annot_right)) - | _ -> None - in - match find_ep tparameter with - | None -> None - | Some t -> Some (tinstr, Ok (Stack_ok (mt_contract t :: stack))))) + | MI0 (Self ep_name) -> + let tinstr = MI0 (Self ep_name) in + let mt_contract t = { (mt_contract t) with annot_variable = Some "self" } in + (match ep_name with + | None -> Some (tinstr, Ok (Stack_ok (mt_contract (fst tparameter) :: stack))) + | Some ep_name -> + let rec find_ep (t, annot) = + match t.mt, annot with + | _, Some a when a = ep_name -> Some t + | MT2 (Or { annot_left; annot_right }, left, right), None -> + (match find_ep (left, annot_left) with + | Some t -> Some t + | None -> find_ep (right, annot_right)) + | _ -> None + in + (match find_ep tparameter with + | None -> None + | Some t -> Some (tinstr, Ok (Stack_ok (mt_contract t :: stack))))) | _ -> assert false in mk_spec "SELF" ~arities:(0, 1) rule +;; let mi_address = mk_spec_basic "ADDRESS" ~arities:(1, 1) (function - | {mt = MT1 (Contract, _)} :: _ -> Some [mt_address] + | { mt = MT1 (Contract, _) } :: _ -> Some [ mt_address ] | _ -> None) +;; let mi_implicit_account = mk_spec_basic "IMPLICIT_ACCOUNT" ~arities:(1, 1) (function - | {mt = MT0 Key_hash} :: _ -> Some [mt_contract mt_unit] + | { mt = MT0 Key_hash } :: _ -> Some [ mt_contract mt_unit ] | _ -> None) +;; let mi_voting_power = mk_spec_basic "VOTING_POWER" ~arities:(1, 1) (function - | {mt = MT0 Key_hash} :: _ -> Some [mt_nat] + | { mt = MT0 Key_hash } :: _ -> Some [ mt_nat ] | _ -> None) +;; -let typecheck_view ~tstorage ({tparameter; onchain_code; offchain_code} as v) = +let typecheck_view ~tstorage ({ tparameter; onchain_code; offchain_code } as v) = let check offchain code = let stack = match tparameter with | None -> - let stack = - if offchain - then Stack_ok [{tstorage with annot_variable = Some "storage"}] - else initial_stack ~tparameter:mt_unit ~tstorage - in - stack + let stack = + if offchain + then Stack_ok [ { tstorage with annot_variable = Some "storage" } ] + else initial_stack ~tparameter:mt_unit ~tstorage + in + stack | Some tparameter -> initial_stack ~tparameter ~tstorage in code (Ok stack) in - { - v with + { v with onchain_code = Option.map (check false) onchain_code ; offchain_code = (check true) offchain_code } +;; let mi_create_contract = let rule ~tparameter:_ stack = function - | MIcreate_contract {tparameter; tstorage; code; views} -> ( - match stack with - | {mt = MT1 (Option, {mt = MT0 Key_hash})} - :: {mt = MT0 Mutez} - :: storage :: tail -> - let code = - code (Ok (initial_stack ~tparameter:(fst tparameter) ~tstorage)) - in - let views = List.map (typecheck_view ~tstorage) views in - if unifiable_types storage tstorage - then - let tinstr = - MIcreate_contract {tparameter; tstorage; code; views} - in - let stack = Ok (Stack_ok (mt_operation :: mt_address :: tail)) in - Some (tinstr, stack) - else None - | _ -> None) + | MIcreate_contract { tparameter; tstorage; code; views } -> + (match stack with + | { mt = MT1 (Option, { mt = MT0 Key_hash }) } + :: { mt = MT0 Mutez } + :: storage + :: tail -> + let code = code (Ok (initial_stack ~tparameter:(fst tparameter) ~tstorage)) in + let views = List.map (typecheck_view ~tstorage) views in + if unifiable_types storage tstorage + then ( + let tinstr = MIcreate_contract { tparameter; tstorage; code; views } in + let stack = Ok (Stack_ok (mt_operation :: mt_address :: tail)) in + Some (tinstr, stack)) + else None + | _ -> None) | _ -> assert false in mk_spec "CREATE_CONTRACT" ~arities:(3, 2) rule +;; let spec_of_prim0 p = let mk name = @@ -1545,12 +1578,13 @@ let spec_of_prim0 p = | None_ t -> mi_none t | Unit_ -> mi_unit | Self _ -> mi_self +;; let spec_of_prim1 ~protocol p = let mk name = let t1, t = Michelson_base.Typing.type_prim1 p in let f = function - | x :: _ when unifiable_types x t1 -> Some [t] + | x :: _ when unifiable_types x t1 -> Some [ t ] | _ -> None in mk_spec_basic name ~arities:(1, 1) f @@ -1595,28 +1629,26 @@ let spec_of_prim1 ~protocol p = | Voting_power -> mi_voting_power | Size -> mi_size | Car | Cdr -> assert false +;; let spec_of_prim2 ~protocol p = let mk ?commutative name = match Michelson_base.Typing.type_prim2 p with - | [((t1, t2), t)] -> - let f = function - | x1 :: x2 :: _ when unifiable_types x1 t1 && unifiable_types x2 t2 -> - Some [t] - | _ -> None - in - mk_spec_basic name ?commutative ~arities:(2, 1) f + | [ ((t1, t2), t) ] -> + let f = function + | x1 :: x2 :: _ when unifiable_types x1 t1 && unifiable_types x2 t2 -> Some [ t ] + | _ -> None + in + mk_spec_basic name ?commutative ~arities:(2, 1) f | instances -> - let f = function - | x1 :: x2 :: _ -> ( - match - List.assoc_opt (strip_annots x1, strip_annots x2) instances - with - | None -> None - | Some t -> Some [t]) - | _ -> None - in - mk_spec_basic name ?commutative ~arities:(2, 1) f + let f = function + | x1 :: x2 :: _ -> + (match List.assoc_opt (strip_annots x1, strip_annots x2) instances with + | None -> None + | Some t -> Some [ t ]) + | _ -> None + in + mk_spec_basic name ?commutative ~arities:(2, 1) f in match p with | Lsl -> mi_shift_left ~protocol @@ -1643,14 +1675,15 @@ let spec_of_prim2 ~protocol p = | Exec -> mi_exec | Apply -> mi_apply | View (_, t) -> mi_view t +;; let spec_of_prim3 p = let mk name = let t1, t2, t3, t = Michelson_base.Typing.type_prim3 p in let f = function | x1 :: x2 :: x3 :: _ - when unifiable_types x1 t1 && unifiable_types x2 t2 - && unifiable_types x3 t3 -> Some [t] + when unifiable_types x1 t1 && unifiable_types x2 t2 && unifiable_types x3 t3 -> + Some [ t ] | _ -> None in mk_spec_basic name ~arities:(3, 1) f @@ -1662,6 +1695,7 @@ let spec_of_prim3 p = | Update -> mi_update | Get_and_update -> mi_get_and_update | Open_chest -> mi_open_chest +;; let spec_of_instr ~protocol = function | MI0 p -> spec_of_prim0 p @@ -1683,8 +1717,8 @@ let spec_of_instr ~protocol = function | MIsetField steps -> mi_set_field steps | MIdup i -> mi_dup i | MIcreate_contract _ -> mi_create_contract - | MImich {name; typesIn; typesOut} -> - mi_mich ~name ~types_in:typesIn ~types_out:typesOut + | MImich { name; typesIn; typesOut } -> + mi_mich ~name ~types_in:typesIn ~types_out:typesOut | MIdip _ -> mi_dip | MIdipn _ -> mi_dipn | MIiter _ -> mi_iter @@ -1702,9 +1736,9 @@ let spec_of_instr ~protocol = function | MIlambda_rec _ -> mi_lambda_rec | MIcomment _ -> mi_comment | MIerror s -> mi_error s +;; let is_commutative ~protocol instr = (spec_of_instr ~protocol instr).commutative - let name_of_instr ~protocol instr = (spec_of_instr ~protocol instr).name (** {1 Type checking} *) @@ -1712,48 +1746,49 @@ let name_of_instr ~protocol instr = (spec_of_instr ~protocol instr).name (* Recognize lists of Elts and lists of Instrs. *) let sanitize_instr, sanitize_literal = let f_literal : _ literal_f -> _ = function - | Seq ({literal = Elt _} :: _ as xs) -> - let f = function - | {literal = Elt (k, v)} -> (k, v) - | _ -> failwith "sanitize: Elt followed by non-Elt" - in - {literal = AnyMap (List.map f xs)} - | Seq ({literal = Instr _} :: _ as xs) -> - let f = function - | {literal = Instr i} -> i - | _ -> failwith "sanitize: instruction followed by non-instruction" - in - {literal = Instr {instr = MIseq (List.map f xs)}} - | literal -> {literal} + | Seq ({ literal = Elt _ } :: _ as xs) -> + let f = function + | { literal = Elt (k, v) } -> k, v + | _ -> failwith "sanitize: Elt followed by non-Elt" + in + { literal = AnyMap (List.map f xs) } + | Seq ({ literal = Instr _ } :: _ as xs) -> + let f = function + | { literal = Instr i } -> i + | _ -> failwith "sanitize: instruction followed by non-instruction" + in + { literal = Instr { instr = MIseq (List.map f xs) } } + | literal -> { literal } in - let f_instr instr = {instr} in - cata {f_instr; f_literal} + let f_instr instr = { instr } in + cata { f_instr; f_literal } +;; (* Match a comb type against the given tuple. *) let rec match_comb t xs = - match (t.mt, xs) with - | _, [x] -> [(t, x)] + match t.mt, xs with + | _, [ x ] -> [ t, x ] | MT2 (Pair _, fst, snd), x :: xs -> (fst, x) :: match_comb snd xs | _ -> failwith "match_comb" +;; (* Roll a list into a right comb. *) let rec comb_literal = function - | [x1; x2] -> {tliteral = Pair (x1, x2); t = Result.map2 mt_pair x1.t x2.t} + | [ x1; x2 ] -> { tliteral = Pair (x1, x2); t = Result.map2 mt_pair x1.t x2.t } | x :: xs -> - let xs = comb_literal xs in - {tliteral = Pair (x, xs); t = Result.map2 mt_pair x.t xs.t} + let xs = comb_literal xs in + { tliteral = Pair (x, xs); t = Result.map2 mt_pair x.t xs.t } | _ -> assert false +;; -let typecheck_literal_f ~tparameter:_ (literal : _ literal_f) - (t : mtype Result.t) = - let tliteral' : - (stack Result.t -> tinstr, mtype Result.t -> tliteral) literal_f = +let typecheck_literal_f ~tparameter:_ (literal : _ literal_f) (t : mtype Result.t) = + let tliteral' : (stack Result.t -> tinstr, mtype Result.t -> tliteral) literal_f = map_literal_f snd snd literal in let r = let open Result in let* t = map_error (fun _ -> "type error") t in - match (t.mt, tliteral') with + match t.mt, tliteral' with | _, (Constant _ as l) -> return l | MT0 Unit, (Unit as l) | MT0 Bool, (Bool _ as l) @@ -1776,30 +1811,26 @@ let typecheck_literal_f ~tparameter:_ (literal : _ literal_f) | MT0 Chest_key, (Bytes _ as l) | MT0 Chest, (Bytes _ as l) -> return l | MT1 (Contract, _), (String _ as l) -> - (* needed for scenarios: "Contract_*" *) return l - | MT2 (Pair _, fst, snd), Pair (x1, x2) -> - return (Pair (x1 (Ok fst), x2 (Ok snd))) + (* needed for scenarios: "Contract_*" *) return l + | MT2 (Pair _, fst, snd), Pair (x1, x2) -> return (Pair (x1 (Ok fst), x2 (Ok snd))) | MT2 (Pair _, _, _), Seq xs -> - let xs = List.map (fun (t, x) -> x (Ok t)) (match_comb t xs) in - return (comb_literal xs).tliteral + let xs = List.map (fun (t, x) -> x (Ok t)) (match_comb t xs) in + return (comb_literal xs).tliteral | MT2 (Or _, left, _), Left x -> return (Left (x (Ok left))) | MT2 (Or _, _, right), Right x -> return (Right (x (Ok right))) | MT1 (Option, t), Some_ x -> return (Some_ (x (Ok t))) | MT1 (Option, _), None_ -> return None_ - | MT1 ((Set | List), t), Seq xs -> - return (Seq (List.map (fun x -> x (Ok t)) xs)) + | MT1 ((Set | List), t), Seq xs -> return (Seq (List.map (fun x -> x (Ok t)) xs)) | MT2 ((Map | Big_map), _tk, _tv), Seq [] -> return (AnyMap []) | MT2 ((Map | Big_map), _tk, _tv), Seq (_ :: _) -> - assert false (* eliminated by 'sanitize' *) + assert false (* eliminated by 'sanitize' *) | MT2 ((Map | Big_map), tk, tv), AnyMap xs -> - let f (k, v) = (k (Ok tk), v (Ok tv)) in - return (AnyMap (List.map f xs)) - | MT2 (Lambda, t_in, _), Instr i -> - return (Instr (i (Ok (Stack_ok [t_in])))) - | MT2 (Lambda, _t1, _), Seq (_ :: _) -> - assert false (* eliminated by 'sanitize' *) + let f (k, v) = k (Ok tk), v (Ok tv) in + return (AnyMap (List.map f xs)) + | MT2 (Lambda, t_in, _), Instr i -> return (Instr (i (Ok (Stack_ok [ t_in ])))) + | MT2 (Lambda, _t1, _), Seq (_ :: _) -> assert false (* eliminated by 'sanitize' *) | MT2 (Lambda, t_in, _), Lambda_rec i -> - return (Lambda_rec (i (Ok (Stack_ok [t_in; t])))) + return (Lambda_rec (i (Ok (Stack_ok [ t_in; t ])))) | ( ( MT0 ( Unit | Bool @@ -1841,100 +1872,100 @@ let typecheck_literal_f ~tparameter:_ (literal : _ literal_f) | AnyMap _ | Instr _ | Lambda_rec _ ) ) -> - let msg = - let literal = map_literal_f fst fst literal in - let l = MLiteral.to_michelson_string show_instr {literal} in - let t = string_of_mtype ~html:false t in - sprintf "Literal %s does not have type %s." l t - in - error msg + let msg = + let literal = map_literal_f fst fst literal in + let l = MLiteral.to_michelson_string show_instr { literal } in + let t = string_of_mtype ~html:false t in + sprintf "Literal %s does not have type %s." l t + in + error msg in match r with | Ok tliteral -> - let r = - sequence_literal_f - (map_literal_f (fun {stack_out} -> stack_out) (fun {t} -> t) tliteral) - in - let t = - match Result.get_error r with - | Some error -> Error (Printf.sprintf "type error in literal %s" error) - | None -> t - in - {tliteral; t} + let r = + sequence_literal_f + (map_literal_f (fun { stack_out } -> stack_out) (fun { t } -> t) tliteral) + in + let t = + match Result.get_error r with + | Some error -> Error (Printf.sprintf "type error in literal %s" error) + | None -> t + in + { tliteral; t } | Error msg -> - let err = Error "type error in literal" in - let tliteral = - map_literal_f (fun f -> f err) (fun f -> f err) tliteral' - in - {tliteral; t = Error msg} + let err = Error "type error in literal" in + let tliteral = map_literal_f (fun f -> f err) (fun f -> f err) tliteral' in + { tliteral; t = Error msg } +;; -let typecheck_instr_f ~protocol ~tparameter i (stack_in : stack Result.t) : - tinstr = +let typecheck_instr_f ~protocol ~tparameter i (stack_in : stack Result.t) : tinstr = let i : (stack Result.t -> tinstr, mtype Result.t -> tliteral) instr_f = map_instr_f snd snd i in let on_error_stack stack_in msg = let err = Error "outer error" in let tinstr = map_instr_f (fun x -> x err) (fun x -> x err) i in - {tinstr; stack_in; stack_out = Error msg} + { tinstr; stack_in; stack_out = Error msg } in - match (stack_in, i) with - | _, (MIcomment _ as tinstr) -> {tinstr; stack_in; stack_out = stack_in} + match stack_in, i with + | _, (MIcomment _ as tinstr) -> { tinstr; stack_in; stack_out = stack_in } | Ok (Stack_ok stack), _ -> - let {rule} = spec_of_instr ~protocol i in - let okify f x = f (Ok x) in - let tinstr, stack_out = rule ~tparameter stack (map_instr_f id okify i) in - {tinstr; stack_in; stack_out} + let { rule } = spec_of_instr ~protocol i in + let okify f x = f (Ok x) in + let tinstr, stack_out = rule ~tparameter stack (map_instr_f id okify i) in + { tinstr; stack_in; stack_out } | Ok Stack_failed, _ -> on_error_stack stack_in "instruction on failed stack" | Error _, _ -> on_error_stack stack_in "previous error" +;; let typecheck_alg ~protocol ~tparameter = let p_instr = typecheck_instr_f ~protocol ~tparameter in let p_literal = typecheck_literal_f ~tparameter in para_alg ~p_instr ~p_literal +;; let typecheck_instr ~protocol ~tparameter stack i = let i = sanitize_instr i in snd (cata_instr (typecheck_alg ~protocol ~tparameter) i) (Ok stack) +;; let typecheck_literal ~protocol ~tparameter t l = let l = sanitize_literal l in snd (cata_literal (typecheck_alg ~protocol ~tparameter) l) (Ok t) +;; let has_error ~path ~accept_missings = - let has_missing_type t = - if accept_missings then [] else has_missing_type ~path t - in + let has_missing_type t = if accept_missings then [] else has_missing_type ~path t in let f_tinstr ~stack_in:_ ~stack_out instr = match stack_out with - | Error s -> [s] - | Ok _ -> ( - match instr with - | MIerror s -> [s] - | MI0 (Nil t) - | MI0 (Empty_set t) - | MI0 (None_ t) - | MI1 (Left (_, _, t)) - | MI1 (Right (_, _, t)) - | MI1 (Contract (_, t)) - | MI1 (Unpack t) -> has_missing_type t - | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> - has_missing_type k @ has_missing_type v - | MIpush (t, _) -> has_missing_type t - | MImich {typesIn; typesOut} -> - List.concat_map has_missing_type typesIn - @ List.concat_map has_missing_type typesOut - | MIlambda (t1, t2, _i) as x -> - has_missing_type t1 @ has_missing_type t2 - @ fold_instr_f ( @ ) (curry fst) [] x - | x -> fold_instr_f ( @ ) (curry fst) [] x) + | Error s -> [ s ] + | Ok _ -> + (match instr with + | MIerror s -> [ s ] + | MI0 (Nil t) + | MI0 (Empty_set t) + | MI0 (None_ t) + | MI1 (Left (_, _, t)) + | MI1 (Right (_, _, t)) + | MI1 (Contract (_, t)) + | MI1 (Unpack t) -> has_missing_type t + | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> + has_missing_type k @ has_missing_type v + | MIpush (t, _) -> has_missing_type t + | MImich { typesIn; typesOut } -> + List.concat_map has_missing_type typesIn + @ List.concat_map has_missing_type typesOut + | MIlambda (t1, t2, _i) as x -> + has_missing_type t1 @ has_missing_type t2 @ fold_instr_f ( @ ) (curry fst) [] x + | x -> fold_instr_f ( @ ) (curry fst) [] x) in let f_tliteral ~t _ = match t with - | Error msg -> [msg] + | Error msg -> [ msg ] | Ok t -> has_missing_type t in - cata_tinstr {f_tinstr; f_tliteral} + cata_tinstr { f_tinstr; f_tliteral } +;; let name_of_instr_exn ~protocol = function | ( MI0 @@ -2023,12 +2054,7 @@ let name_of_instr_exn ~protocol = function | View _ ) | MIdrop | MIswap | MI3 - ( Slice - | Update - | Get_and_update - | Transfer_tokens - | Check_signature - | Open_chest ) + (Slice | Update | Get_and_update | Transfer_tokens | Check_signature | Open_chest) | MImich _ | MIdropn _ | MIdup _ @@ -2059,22 +2085,26 @@ let name_of_instr_exn ~protocol = function | MIseq _ -> failwith "name_of_instr_exn: MIseq" | MIcreate_contract _ -> "CREATE_CONTRACT" | MI2 Sapling_verify_update -> "SAPLING_VERIFY_UPDATE" +;; let two_field_annots = function - | Some a1, Some a2 -> ["%" ^ a1; "%" ^ a2] - | Some a1, None -> ["%" ^ a1] - | None, Some a2 -> ["%"; "%" ^ a2] + | Some a1, Some a2 -> [ "%" ^ a1; "%" ^ a2 ] + | Some a1, None -> [ "%" ^ a1 ] + | None, Some a2 -> [ "%"; "%" ^ a2 ] | None, None -> [] +;; -let display_view display_instr {name; tparameter; treturn; onchain_code} = +let display_view display_instr { name; tparameter; treturn; onchain_code } = match onchain_code with | None -> "" | Some code -> - sprintf "\nview\n %S %s %s\n%s;" name - (string_of_mtype ~protect:() ~html:false - (Option.default mt_unit tparameter)) - (string_of_mtype ~protect:() ~html:false treturn) - (display_instr code) + sprintf + "\nview\n %S %s %s\n%s;" + name + (string_of_mtype ~protect:() ~html:false (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:false treturn) + (display_instr code) +;; let buffer_f ~protocol ~html ~show_stack ~new_line b = let new_line = if new_line then "\n" else "" in @@ -2102,9 +2132,9 @@ let buffer_f ~protocol ~html ~show_stack ~new_line b = in let sub1 name x = prot (fun () -> - Buffer.add_string b name; - Buffer.add_string b " "; - x indent true) + Buffer.add_string b name; + Buffer.add_string b " "; + x indent true) in match x with | Int i -> Buffer.add_string b (Big_int.string_of_big_int i) @@ -2113,30 +2143,29 @@ let buffer_f ~protocol ~html ~show_stack ~new_line b = | Bool true -> Buffer.add_string b "True" | Bool false -> Buffer.add_string b "False" | Pair (l, r) -> - prot (fun () -> - Buffer.add_string b "Pair "; - l indent true; - Buffer.add_string b " "; - r indent true) + prot (fun () -> + Buffer.add_string b "Pair "; + l indent true; + Buffer.add_string b " "; + r indent true) | None_ -> Buffer.add_string b "None" | Left x -> sub1 "Left" x | Right x -> sub1 "Right" x | Some_ x -> sub1 "Some" x | Bytes string_bytes -> - Buffer.add_string b "0x"; - Buffer.add_string b Hex.(show (of_string string_bytes)) + Buffer.add_string b "0x"; + Buffer.add_string b Hex.(show (of_string string_bytes)) | Seq xs -> - Misc.buffer_protect b true "{" "}" (fun () -> - Misc.buffer_concat b "; " (fun x -> x indent false) xs) + Misc.buffer_protect b true "{" "}" (fun () -> + Misc.buffer_concat b "; " (fun x -> x indent false) xs) | Elt (k, v) -> elt (k, v) | AnyMap xs -> - Misc.buffer_protect b true "{" "}" (fun () -> - Misc.buffer_concat b "; " elt xs) + Misc.buffer_protect b true "{" "}" (fun () -> Misc.buffer_concat b "; " elt xs) | Instr i -> i ~sub:false (indent + 2) | Lambda_rec i -> - prot (fun () -> - line_str "Lambda_rec "; - i ~sub:false (indent + 2)) + prot (fun () -> + line_str "Lambda_rec "; + i ~sub:false (indent + 2)) | Constant hash -> bprintf b "(constant %S)" hash in let f_tinstr ~stack_in:_ ~stack_out x ~sub indent = @@ -2183,236 +2212,233 @@ let buffer_f ~protocol ~html ~show_stack ~new_line b = out_str ";" in (match x with - | MIseq [] -> - do_indent (); - out_str "{}" - | MIseq l -> - do_indent (); - out_str "{"; - List.iter - (fun i -> - out_str new_line; - i ~sub:false (indent + 2)) - l; - out_str new_line; - do_indent (); - out_str "}"; - if not sub then out_str ";" - | MIdip code -> sub1 "DIP" code - | MIdipn (n, code) -> sub1 (sprintf "DIP %i" n) code - | MIloop code -> sub1 "LOOP" code - | MIloop_left code -> sub1 "LOOP_LEFT" code - | MIiter code -> sub1 "ITER" code - | MImap code -> sub1 "MAP" code - | MIif_left (l, r) -> sub2 "IF_LEFT" l r - | MIif_none (l, r) -> sub2 "IF_NONE" l r - | MIif_cons (l, r) -> sub2 "IF_CONS" l r - | MIif (l, r) -> sub2 "IF" l r - | MIcomment comments -> - let lines = - List.concat (List.map (String.split_on_char '\n') comments) - in - List.iteri - (fun i line -> - if i <> 0 then out_str new_line; - do_indent (); - out_str (span "comment" (sprintf "# %s" line))) - lines - | MIdig n -> with_stack (fun () -> out "DIG %d" n) - | MIdug n -> with_stack (fun () -> out "DUG %d" n) - | MIdropn n -> with_stack (fun () -> out "DROP %d" n) - | MIdup 1 -> with_stack (fun () -> out_str "DUP") - | MIunpair [true; true] -> with_stack (fun () -> out_str "UNPAIR") - | MI0 (Sapling_empty_state {memo}) -> - with_stack (fun () -> out "SAPLING_EMPTY_STATE %d" memo) - | MIdup n -> with_stack (fun () -> out "DUP %d" n) - | MIunpair n -> with_stack (fun () -> out "UNPAIR %s" (unpair_arg n)) - | MIpairn n -> with_stack (fun () -> out "PAIR %d" n) - | MI1 (Getn n) -> with_stack (fun () -> out "GET %d" n) - | MI2 (Updaten n) -> with_stack (fun () -> out "UPDATE %d" n) - | MI2 (View (name, t)) -> - with_stack (fun () -> - out "VIEW %S %s" name (string_of_mtype ~protect:() ~html t)) - | MIerror error -> - do_indent (); - out_str (span "partial-type" (sprintf "MIerror: %s" error)) - | MI0 (Empty_set t) - | MI0 (Nil t) - | MI0 (None_ t) - | MI1 (Contract (None, t)) - | MI1 (Unpack t) - | MI1 (Cast t) -> - with_stack (fun () -> - out_str (name_of_instr_exn ~protocol x); - out_str " "; - buffer_mtype ~html ~protect:() b t) - | MI1 (Rename a) -> - with_stack (fun () -> - out_str (name_of_instr_exn ~protocol x); - match a with - | None -> () - | Some a -> - out_str " @"; - out_str a) - | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> - with_stack (fun () -> - out_str (name_of_instr_exn ~protocol x); - out_str " "; - out_str - (String.concat " " - [ - string_of_mtype ~protect:() ~html k - ; string_of_mtype ~protect:() ~html v - ])) - | MI1 (Left (a1, a2, t) | Right (a1, a2, t)) -> - with_stack (fun () -> - out_str - (String.concat " " - (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2))); - out_str " "; - out_str (string_of_mtype ~protect:() ~html t)) - | MI2 (Pair (a1, a2)) -> - with_stack (fun () -> - out_str - (String.concat " " - (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2)))) - | MI1 (Contract (Some ep, t)) -> - with_stack (fun () -> - out "CONTRACT %%%s %s" ep (string_of_mtype ~protect:() ~html t)) - | MIpush (t, l) -> - with_stack (fun () -> - out "PUSH %s " (string_of_mtype ~protect:() ~html t); - l indent true) - | MI0 (Self (Some entrypoint)) -> - with_stack (fun () -> out "SELF %%%s" entrypoint) - | MIlambda (t1, t2, l) -> - line "LAMBDA"; - line " %s" (string_of_mtype ~protect:() ~html t1); - line " %s" (string_of_mtype ~protect:() ~html t2); - l ~sub:true (indent + 2); - out_str ";" - | MIlambda_rec (t1, t2, l) -> - line "LAMBDA_REC"; - line " %s" (string_of_mtype ~protect:() ~html t1); - line " %s" (string_of_mtype ~protect:() ~html t2); - l ~sub:true (indent + 2); - out_str ";" - | MI1 (Emit (tag, ty)) -> - (do_indent (); - out "EMIT"; - (match tag with + | MIseq [] -> + do_indent (); + out_str "{}" + | MIseq l -> + do_indent (); + out_str "{"; + List.iter + (fun i -> + out_str new_line; + i ~sub:false (indent + 2)) + l; + out_str new_line; + do_indent (); + out_str "}"; + if not sub then out_str ";" + | MIdip code -> sub1 "DIP" code + | MIdipn (n, code) -> sub1 (sprintf "DIP %i" n) code + | MIloop code -> sub1 "LOOP" code + | MIloop_left code -> sub1 "LOOP_LEFT" code + | MIiter code -> sub1 "ITER" code + | MImap code -> sub1 "MAP" code + | MIif_left (l, r) -> sub2 "IF_LEFT" l r + | MIif_none (l, r) -> sub2 "IF_NONE" l r + | MIif_cons (l, r) -> sub2 "IF_CONS" l r + | MIif (l, r) -> sub2 "IF" l r + | MIcomment comments -> + let lines = List.concat (List.map (String.split_on_char '\n') comments) in + List.iteri + (fun i line -> + if i <> 0 then out_str new_line; + do_indent (); + out_str (span "comment" (sprintf "# %s" line))) + lines + | MIdig n -> with_stack (fun () -> out "DIG %d" n) + | MIdug n -> with_stack (fun () -> out "DUG %d" n) + | MIdropn n -> with_stack (fun () -> out "DROP %d" n) + | MIdup 1 -> with_stack (fun () -> out_str "DUP") + | MIunpair [ true; true ] -> with_stack (fun () -> out_str "UNPAIR") + | MI0 (Sapling_empty_state { memo }) -> + with_stack (fun () -> out "SAPLING_EMPTY_STATE %d" memo) + | MIdup n -> with_stack (fun () -> out "DUP %d" n) + | MIunpair n -> with_stack (fun () -> out "UNPAIR %s" (unpair_arg n)) + | MIpairn n -> with_stack (fun () -> out "PAIR %d" n) + | MI1 (Getn n) -> with_stack (fun () -> out "GET %d" n) + | MI2 (Updaten n) -> with_stack (fun () -> out "UPDATE %d" n) + | MI2 (View (name, t)) -> + with_stack (fun () -> out "VIEW %S %s" name (string_of_mtype ~protect:() ~html t)) + | MIerror error -> + do_indent (); + out_str (span "partial-type" (sprintf "MIerror: %s" error)) + | MI0 (Empty_set t) + | MI0 (Nil t) + | MI0 (None_ t) + | MI1 (Contract (None, t)) + | MI1 (Unpack t) + | MI1 (Cast t) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + out_str " "; + buffer_mtype ~html ~protect:() b t) + | MI1 (Rename a) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + match a with + | None -> () + | Some a -> + out_str " @"; + out_str a) + | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> + with_stack (fun () -> + out_str (name_of_instr_exn ~protocol x); + out_str " "; + out_str + (String.concat + " " + [ string_of_mtype ~protect:() ~html k; string_of_mtype ~protect:() ~html v ])) + | MI1 (Left (a1, a2, t) | Right (a1, a2, t)) -> + with_stack (fun () -> + out_str + (String.concat + " " + (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2))); + out_str " "; + out_str (string_of_mtype ~protect:() ~html t)) + | MI2 (Pair (a1, a2)) -> + with_stack (fun () -> + out_str + (String.concat + " " + (name_of_instr_exn ~protocol x :: two_field_annots (a1, a2)))) + | MI1 (Contract (Some ep, t)) -> + with_stack (fun () -> + out "CONTRACT %%%s %s" ep (string_of_mtype ~protect:() ~html t)) + | MIpush (t, l) -> + with_stack (fun () -> + out "PUSH %s " (string_of_mtype ~protect:() ~html t); + l indent true) + | MI0 (Self (Some entrypoint)) -> with_stack (fun () -> out "SELF %%%s" entrypoint) + | MIlambda (t1, t2, l) -> + line "LAMBDA"; + line " %s" (string_of_mtype ~protect:() ~html t1); + line " %s" (string_of_mtype ~protect:() ~html t2); + l ~sub:true (indent + 2); + out_str ";" + | MIlambda_rec (t1, t2, l) -> + line "LAMBDA_REC"; + line " %s" (string_of_mtype ~protect:() ~html t1); + line " %s" (string_of_mtype ~protect:() ~html t2); + l ~sub:true (indent + 2); + out_str ";" + | MI1 (Emit (tag, ty)) -> + (do_indent (); + out "EMIT"; + (match tag with | None -> () | Some tag -> out " %s" tag); - match ty with + match ty with + | None -> () + | Some ty -> out " %s" (string_of_mtype ~protect:() ~html ty)); + out_str ";" + | MIcreate_contract { tparameter = t, annot; tstorage; code; views } -> + let view { name; tparameter; treturn; onchain_code } = + match onchain_code with | None -> () - | Some ty -> out " %s" (string_of_mtype ~protect:() ~html ty)); - out_str ";" - | MIcreate_contract {tparameter = t, annot; tstorage; code; views} -> - let view {name; tparameter; treturn; onchain_code} = - match onchain_code with - | None -> () - | Some code -> - line " view"; - line " %S %s %s" name - (string_of_mtype ~protect:() ~html:false - (Option.default mt_unit tparameter)) - (string_of_mtype ~protect:() ~html:false treturn); - code ~sub:true (indent + 5); - out ";%s" new_line - in - line "CREATE_CONTRACT"; - line " { parameter %s;" (string_of_tparameter ~html (t, annot)); - line " storage %s;" (string_of_mtype ~protect:() ~html tstorage); - line " code"; - code ~sub:true (indent + 5); - out ";%s" new_line; - List.iter view views; - do_indent (); - out " };" - | ( MI0 - ( Self None - | Sender - | Source - | Amount - | Balance - | Level - | Now - | Self_address - | Chain_id - | Total_voting_power - | Unit_ ) - | MI1 - ( Car - | Cdr - | Some_ - | Eq - | Abs - | Neg - | Nat - | Int - | Bytes - | IsNat - | Neq - | Le - | Lt - | Ge - | Gt - | Not - | Concat1 - | Size - | Address - | Implicit_account - | Pack - | Hash_key - | Blake2b - | Sha256 - | Sha512 - | Keccak - | Sha3 - | Set_delegate - | Read_ticket - | Join_tickets - | Pairing_check - | Voting_power ) - | MI1_fail (Failwith | Never) - | MI2 - ( Add - | Mul - | Sub - | Sub_mutez - | Lsr - | Lsl - | Xor - | Ediv - | And - | Or - | Cons - | Compare - | Concat2 - | Get - | Mem - | Exec - | Apply - | Sapling_verify_update - | Ticket - | Ticket_deprecated - | Split_ticket ) - | MI3 - ( Slice - | Update - | Get_and_update - | Transfer_tokens - | Check_signature - | Open_chest ) - | MIdrop - | MIswap - | MImich _ - | MIfield _ - | MIsetField _ - | MIconcat1 - | MIconcat2 - | MIconcat_unresolved ) as simple -> - with_stack (fun () -> out_str (name_of_instr_exn ~protocol simple))); + | Some code -> + line " view"; + line + " %S %s %s" + name + (string_of_mtype ~protect:() ~html:false (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:false treturn); + code ~sub:true (indent + 5); + out ";%s" new_line + in + line "CREATE_CONTRACT"; + line " { parameter %s;" (string_of_tparameter ~html (t, annot)); + line " storage %s;" (string_of_mtype ~protect:() ~html tstorage); + line " code"; + code ~sub:true (indent + 5); + out ";%s" new_line; + List.iter view views; + do_indent (); + out " };" + | ( MI0 + ( Self None + | Sender + | Source + | Amount + | Balance + | Level + | Now + | Self_address + | Chain_id + | Total_voting_power + | Unit_ ) + | MI1 + ( Car + | Cdr + | Some_ + | Eq + | Abs + | Neg + | Nat + | Int + | Bytes + | IsNat + | Neq + | Le + | Lt + | Ge + | Gt + | Not + | Concat1 + | Size + | Address + | Implicit_account + | Pack + | Hash_key + | Blake2b + | Sha256 + | Sha512 + | Keccak + | Sha3 + | Set_delegate + | Read_ticket + | Join_tickets + | Pairing_check + | Voting_power ) + | MI1_fail (Failwith | Never) + | MI2 + ( Add + | Mul + | Sub + | Sub_mutez + | Lsr + | Lsl + | Xor + | Ediv + | And + | Or + | Cons + | Compare + | Concat2 + | Get + | Mem + | Exec + | Apply + | Sapling_verify_update + | Ticket + | Ticket_deprecated + | Split_ticket ) + | MI3 + ( Slice + | Update + | Get_and_update + | Transfer_tokens + | Check_signature + | Open_chest ) + | MIdrop + | MIswap + | MImich _ + | MIfield _ + | MIsetField _ + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved ) as simple -> + with_stack (fun () -> out_str (name_of_instr_exn ~protocol simple))); let full = match x with | MIerror _ -> Some () @@ -2420,53 +2446,57 @@ let buffer_f ~protocol ~html ~show_stack ~new_line b = | _ -> None in if show_stack && not sub - then + then ( match stack_out with | Ok inst -> - out " %s %s" (span "comment" "#") - (span "stack" (sprintf "%s" (string_of_stack ?full inst))) - | Error msg -> out " # Error: %s" (span "partial-type" msg) + out + " %s %s" + (span "comment" "#") + (span "stack" (sprintf "%s" (string_of_stack ?full inst))) + | Error msg -> out " # Error: %s" (span "partial-type" msg)) in - {f_tinstr; f_tliteral} + { f_tinstr; f_tliteral } +;; let _buffer_tliteral ~protocol ~html ~show_stack b indent protect x = - cata_tliteral - (buffer_f ~protocol ~html ~show_stack ~new_line:true b) - x indent protect + cata_tliteral (buffer_f ~protocol ~html ~show_stack ~new_line:true b) x indent protect +;; let buffer_tinstr ~protocol ~html ~show_stack ~sub ~new_line b indent x = cata_tinstr (buffer_f ~protocol ~html ~show_stack ~new_line b) x ~sub indent +;; let seq_snoc xs x = match xs with - | {tinstr = MIseq xs; stack_in} -> - {tinstr = MIseq (xs @ [x]); stack_in; stack_out = x.stack_out} - | xs -> - {tinstr = MIseq [xs; x]; stack_in = xs.stack_in; stack_out = x.stack_out} + | { tinstr = MIseq xs; stack_in } -> + { tinstr = MIseq (xs @ [ x ]); stack_in; stack_out = x.stack_out } + | xs -> { tinstr = MIseq [ xs; x ]; stack_in = xs.stack_in; stack_out = x.stack_out } +;; let wrap_in_seq = function - | {tinstr = MIseq _} as i -> i - | i -> {tinstr = MIseq [i]; stack_in = i.stack_in; stack_out = i.stack_out} + | { tinstr = MIseq _ } as i -> i + | i -> { tinstr = MIseq [ i ]; stack_in = i.stack_in; stack_out = i.stack_out } +;; let insert_subsequences = let f_tinstr ~stack_in ~stack_out = function - | MIseq _ as tinstr -> {tinstr; stack_in; stack_out} - | tinstr -> - {tinstr = map_instr_f wrap_in_seq id tinstr; stack_in; stack_out} + | MIseq _ as tinstr -> { tinstr; stack_in; stack_out } + | tinstr -> { tinstr = map_instr_f wrap_in_seq id tinstr; stack_in; stack_out } in - cata_tinstr {f_tinstr; f_tliteral = (fun ~t tliteral -> {tliteral; t})} + cata_tinstr { f_tinstr; f_tliteral = (fun ~t tliteral -> { tliteral; t }) } +;; let display_tinstr ~protocol ~show_stack ~new_line indent inst = let inst = insert_subsequences inst in Misc.with_buffer (fun b -> - buffer_tinstr ~protocol ~html:false ~show_stack ~sub:true ~new_line b - indent inst) + buffer_tinstr ~protocol ~html:false ~show_stack ~sub:true ~new_line b indent inst) +;; let render_tinstr ~protocol ~show_stack indent inst = let inst = insert_subsequences inst in Misc.with_buffer (fun b -> - buffer_tinstr ~protocol ~html:true ~show_stack ~sub:true ~new_line:true b - indent inst) + buffer_tinstr ~protocol ~html:true ~show_stack ~sub:true ~new_line:true b indent inst) +;; let pretty_literal_f literal wrap ppf = let open Format in @@ -2484,27 +2514,28 @@ let pretty_literal_f literal wrap ppf = | Some_ x -> wrap (fun ppf -> fprintf ppf "Some %t" (x true)) | Bytes s -> fprintf ppf "0x%s" Hex.(show (of_string s)) | Seq xs -> - let f i x = - let x = x false in - let s = Format.asprintf "%t" x in - if i = 0 || s = "" then fprintf ppf "%s" s else fprintf ppf "; %s" s - in - fprintf ppf "{"; - List.iteri f xs; - fprintf ppf "}" + let f i x = + let x = x false in + let s = Format.asprintf "%t" x in + if i = 0 || s = "" then fprintf ppf "%s" s else fprintf ppf "; %s" s + in + fprintf ppf "{"; + List.iteri f xs; + fprintf ppf "}" | Elt (k, v) -> wrap (fun ppf -> fprintf ppf "Elt %t %t" (k true) (v true)) | Instr i -> i true ppf | Lambda_rec i -> wrap (fun ppf -> fprintf ppf "Lambda_rec %t" (i true)) | AnyMap xs -> - let f i (k, v) = - if i = 0 - then fprintf ppf "Elt %t %t" (k true) (v true) - else fprintf ppf "; Elt %t %t" (k true) (v true) - in - fprintf ppf "{"; - List.iteri f xs; - fprintf ppf "}" + let f i (k, v) = + if i = 0 + then fprintf ppf "Elt %t %t" (k true) (v true) + else fprintf ppf "; Elt %t %t" (k true) (v true) + in + fprintf ppf "{"; + List.iteri f xs; + fprintf ppf "}" | Constant hash -> wrap (fun ppf -> fprintf ppf "constant %S" hash) +;; let pretty_instr_f ~protocol i wrap ppf = let open Format in @@ -2513,16 +2544,16 @@ let pretty_instr_f ~protocol i wrap ppf = match i with | MIseq [] -> fprintf ppf "{}" | MIseq (x :: xs) -> - fprintf ppf "{ %t" (x false); - List.iter (fun x -> fprintf ppf "; %t" (x false)) xs; - fprintf ppf " }" + fprintf ppf "{ %t" (x false); + List.iter (fun x -> fprintf ppf "; %t" (x false)) xs; + fprintf ppf " }" | MIdipn (n, i) -> wrap (fun ppf -> fprintf ppf "DIP %i %t" n (i true)) | MIdip i | MIloop i | MIloop_left i | MIiter i | MImap i -> - fprintf ppf "%t %t" name (i true) - | MIif_left (i1, i2) | MIif_none (i1, i2) | MIif_cons (i1, i2) | MIif (i1, i2) - -> wrap (fun ppf -> fprintf ppf "%t %t %t" name (i1 true) (i2 true)) + fprintf ppf "%t %t" name (i true) + | MIif_left (i1, i2) | MIif_none (i1, i2) | MIif_cons (i1, i2) | MIif (i1, i2) -> + wrap (fun ppf -> fprintf ppf "%t %t %t" name (i1 true) (i2 true)) | MIdup 1 -> wrap (fun ppf -> fprintf ppf "%t" name) - | MIunpair [true; true] -> wrap (fun ppf -> fprintf ppf "%t" name) + | MIunpair [ true; true ] -> wrap (fun ppf -> fprintf ppf "%t" name) | MIunpair n -> wrap (fun ppf -> fprintf ppf "%t %s" name (unpair_arg n)) | MIpairn n -> wrap (fun ppf -> fprintf ppf "%t %d" name n) | MIdig n @@ -2531,70 +2562,71 @@ let pretty_instr_f ~protocol i wrap ppf = | MI1 (Getn n) | MI2 (Updaten n) | MIdup n - | MI0 (Sapling_empty_state {memo = n}) -> - wrap (fun ppf -> fprintf ppf "%t %d" name n) + | MI0 (Sapling_empty_state { memo = n }) -> wrap (fun ppf -> fprintf ppf "%t %d" name n) | MIcomment _xs -> wrap (fun _ppf -> ()) | MIerror msg -> wrap (fun ppf -> fprintf ppf "ERROR %s" msg) | MI1 (Cast t) | MI0 (Nil t | Empty_set t | None_ t) | MI1 (Contract (None, t) | Unpack t | Left (_, _, t) | Right (_, _, t)) -> - wrap (fun ppf -> - fprintf ppf "%t %s" name (string_of_mtype ~protect:() ~html:false t)) + wrap (fun ppf -> fprintf ppf "%t %s" name (string_of_mtype ~protect:() ~html:false t)) | MI1 (Rename a) -> - let a = Option.cata "" (( ^ ) "@") a in - wrap (fun ppf -> fprintf ppf "%t%s" name a) + let a = Option.cata "" (( ^ ) "@") a in + wrap (fun ppf -> fprintf ppf "%t%s" name a) | MI0 (Empty_bigmap (k, v) | Empty_map (k, v)) -> - wrap (fun ppf -> - fprintf ppf "%t %s %s" name - (string_of_mtype ~protect:() ~html:false k) - (string_of_mtype ~protect:() ~html:false v)) + wrap (fun ppf -> + fprintf + ppf + "%t %s %s" + name + (string_of_mtype ~protect:() ~html:false k) + (string_of_mtype ~protect:() ~html:false v)) | MI1 (Contract (Some ep, t)) -> - wrap (fun ppf -> - fprintf ppf "CONTRACT %%%s %s" ep - (string_of_mtype ~protect:() ~html:false t)) + wrap (fun ppf -> + fprintf ppf "CONTRACT %%%s %s" ep (string_of_mtype ~protect:() ~html:false t)) | MI2 (View (name, t)) -> - wrap (fun ppf -> - fprintf ppf "VIEW %S %s" name - (string_of_mtype ~protect:() ~html:false t)) + wrap (fun ppf -> + fprintf ppf "VIEW %S %s" name (string_of_mtype ~protect:() ~html:false t)) | MIlambda (t1, t2, c) -> - wrap (fun ppf -> - let t1 = string_of_mtype ~protect:() ~html:false t1 in - let t2 = string_of_mtype ~protect:() ~html:false t2 in - fprintf ppf "LAMBDA %s %s %t" t1 t2 (c true)) + wrap (fun ppf -> + let t1 = string_of_mtype ~protect:() ~html:false t1 in + let t2 = string_of_mtype ~protect:() ~html:false t2 in + fprintf ppf "LAMBDA %s %s %t" t1 t2 (c true)) | MIlambda_rec (t1, t2, c) -> - wrap (fun ppf -> - let t1 = string_of_mtype ~protect:() ~html:false t1 in - let t2 = string_of_mtype ~protect:() ~html:false t2 in - fprintf ppf "LAMBDA_REC %s %s %t" t1 t2 (c true)) + wrap (fun ppf -> + let t1 = string_of_mtype ~protect:() ~html:false t1 in + let t2 = string_of_mtype ~protect:() ~html:false t2 in + fprintf ppf "LAMBDA_REC %s %s %t" t1 t2 (c true)) | MI1 (Emit (tag, ty)) -> - wrap (fun ppf -> - let tag = - match tag with - | None -> "" - | Some tag -> tag - in - let ty = - match ty with - | None -> "" - | Some ty -> string_of_mtype ~protect:() ~html:false ty - in - fprintf ppf "EMIT%s%s" tag ty) - | MIpush (t, l) -> - wrap (fun ppf -> - let t = string_of_mtype ~protect:() ~html:false t in - let l = l true in - fprintf ppf "PUSH %s %t" t l) - | MIcreate_contract {tparameter = tparameter, annot; tstorage; code; views} -> - let display_instr i = Format.asprintf "%t" (i false) in - let views = - String.concat "\n" - (List.map (fun v -> "; " ^ display_view display_instr v) views) + wrap (fun ppf -> + let tag = + match tag with + | None -> "" + | Some tag -> tag in - wrap (fun ppf -> - fprintf ppf "CREATE_CONTRACT { parameter %s; storage %s; code %t%s}" - (string_of_tparameter ~html:false (tparameter, annot)) - (string_of_mtype ~protect:() ~html:false tstorage) - (code true) views) + let ty = + match ty with + | None -> "" + | Some ty -> string_of_mtype ~protect:() ~html:false ty + in + fprintf ppf "EMIT%s%s" tag ty) + | MIpush (t, l) -> + wrap (fun ppf -> + let t = string_of_mtype ~protect:() ~html:false t in + let l = l true in + fprintf ppf "PUSH %s %t" t l) + | MIcreate_contract { tparameter = tparameter, annot; tstorage; code; views } -> + let display_instr i = Format.asprintf "%t" (i false) in + let views = + String.concat "\n" (List.map (fun v -> "; " ^ display_view display_instr v) views) + in + wrap (fun ppf -> + fprintf + ppf + "CREATE_CONTRACT { parameter %s; storage %s; code %t%s}" + (string_of_tparameter ~html:false (tparameter, annot)) + (string_of_mtype ~protect:() ~html:false tstorage) + (code true) + views) | MI0 ( Sender | Source @@ -2664,59 +2696,58 @@ let pretty_instr_f ~protocol i wrap ppf = | Ticket | Ticket_deprecated | Split_ticket ) - | MI3 - ( Slice - | Update - | Get_and_update - | Transfer_tokens - | Check_signature - | Open_chest ) - | MIdrop | MIswap | MImich _ | MIfield _ | MIsetField _ - | MIconcat1 | MIconcat2 | MIconcat_unresolved - -> wrap (fun ppf -> fprintf ppf "%t" name) + | MI3 (Slice | Update | Get_and_update | Transfer_tokens | Check_signature | Open_chest) + | MIdrop + | MIswap + | MImich _ + | MIfield _ + | MIsetField _ + | MIconcat1 + | MIconcat2 + | MIconcat_unresolved -> wrap (fun ppf -> fprintf ppf "%t" name) +;; let size_instr, _size_literal = let f_instr = fold_instr_f ( + ) ( + ) 1 in let f_literal = fold_literal_f ( + ) ( + ) 1 in - cata {f_instr; f_literal} + cata { f_instr; f_literal } +;; let pretty_alg ~protocol = - {f_instr = pretty_instr_f ~protocol; f_literal = pretty_literal_f} + { f_instr = pretty_instr_f ~protocol; f_literal = pretty_literal_f } +;; let _pretty_instr ~protocol = cata_instr (pretty_alg ~protocol) - let pretty_literal ~protocol = cata_literal (pretty_alg ~protocol) +let string_of_literal ~protocol m = Format.asprintf "%t" (pretty_literal ~protocol m true) -let string_of_literal ~protocol m = - Format.asprintf "%t" (pretty_literal ~protocol m true) - -type contract = { - tparameter : mtype * string option +type contract = + { tparameter : mtype * string option ; tstorage : mtype ; code : instr ; views : instr view list -} -[@@deriving show {with_path = false}] + } +[@@deriving show { with_path = false }] -type instance = { - contract : contract +type instance = + { contract : contract ; storage : literal option -} -[@@deriving show {with_path = false}] + } +[@@deriving show { with_path = false }] -type tcontract = { - tparameter : mtype * string option +type tcontract = + { tparameter : mtype * string option ; tstorage : mtype ; code : tinstr ; views : tinstr view list -} -[@@deriving show {with_path = false}] + } +[@@deriving show { with_path = false }] -type tinstance = { - contract : tcontract +type tinstance = + { contract : tcontract ; storage : tliteral option -} -[@@deriving show {with_path = false}] + } +[@@deriving show { with_path = false }] module Of_micheline = struct open Micheline @@ -2724,133 +2755,129 @@ module Of_micheline = struct let rec mtype x = fst (mtype_annotated x) and mtype_annotated = function - | Micheline.Primitive {name; annotations; arguments} as p -> - let mt = - match (name, arguments) with - | "pair", [t1; t2] -> - let fst, annot_fst = mtype_annotated t1 in - let snd, annot_snd = mtype_annotated t2 in - mt_pair ?annot_fst ?annot_snd fst snd - | "pair", l -> ( - match List.rev_map mtype_annotated l with - | [] -> assert false - | (last, annot) :: rest -> - fst - (List.fold_left - (fun (snd, annot_snd) (fst, annot_fst) -> - (mt_pair ?annot_fst ?annot_snd fst snd, None)) - (last, annot) rest)) - | "or", [t1; t2] -> - let left, annot_left = mtype_annotated t1 in - let right, annot_right = mtype_annotated t2 in - mt_or ?annot_left ?annot_right left right - | "unit", [] -> mt_unit - | "bool", [] -> mt_bool - | "mutez", [] -> mt_mutez - | "timestamp", [] -> mt_timestamp - | "nat", [] -> mt_nat - | "int", [] -> mt_int - | "string", [] -> mt_string - | "key", [] -> mt_key - | "signature", [] -> mt_signature - | "bytes", [] -> mt_bytes - | "chain_id", [] -> mt_chain_id - | "key_hash", [] -> mt_key_hash - | "contract", [t] -> mt_contract (mtype t) - | "address", [] -> mt_address - | "list", [t] -> mt_list (mtype t) - | "option", [t] -> mt_option (mtype t) - | "set", [t] -> mt_set (mtype t) - | "map", [t1; t2] -> mt_map (mtype t1) (mtype t2) - | "big_map", [t1; t2] -> mt_big_map (mtype t1) (mtype t2) - | "lambda", [t1; t2] -> mt_lambda (mtype t1) (mtype t2) - | "operation", [] -> mt_operation - | "sapling_state", [Int memo] -> mt_sapling_state (int_of_string memo) - | "sapling_transaction", [Int memo] -> - mt_sapling_transaction (int_of_string memo) - | "never", [] -> mt_never - | "ticket", [t] -> mt_ticket (mtype t) - | "bls12_381_g1", [] -> mt_bls12_381_g1 - | "bls12_381_g2", [] -> mt_bls12_381_g2 - | "bls12_381_fr", [] -> mt_bls12_381_fr - | "chest_key", [] -> mt_chest_key - | "chest", [] -> mt_chest - | _ -> mk_mtype (MT_var (sprintf "Parse type error %S" (pretty "" p))) - in - List.fold_left - (fun (mt, fa) a -> - let update = function - | Some _ -> failwith "duplicate annotation" - | None -> Some (String.sub a 1 (String.length a - 1)) - in - match a.[0] with - | ':' -> ({mt with annot_type = update mt.annot_type}, fa) - | '@' -> ({mt with annot_variable = update mt.annot_variable}, fa) - | '%' -> (mt, update fa) - | _ -> failwith "cannot parse annotation") - (mt, None) annotations + | Micheline.Primitive { name; annotations; arguments } as p -> + let mt = + match name, arguments with + | "pair", [ t1; t2 ] -> + let fst, annot_fst = mtype_annotated t1 in + let snd, annot_snd = mtype_annotated t2 in + mt_pair ?annot_fst ?annot_snd fst snd + | "pair", l -> + (match List.rev_map mtype_annotated l with + | [] -> assert false + | (last, annot) :: rest -> + fst + (List.fold_left + (fun (snd, annot_snd) (fst, annot_fst) -> + mt_pair ?annot_fst ?annot_snd fst snd, None) + (last, annot) + rest)) + | "or", [ t1; t2 ] -> + let left, annot_left = mtype_annotated t1 in + let right, annot_right = mtype_annotated t2 in + mt_or ?annot_left ?annot_right left right + | "unit", [] -> mt_unit + | "bool", [] -> mt_bool + | "mutez", [] -> mt_mutez + | "timestamp", [] -> mt_timestamp + | "nat", [] -> mt_nat + | "int", [] -> mt_int + | "string", [] -> mt_string + | "key", [] -> mt_key + | "signature", [] -> mt_signature + | "bytes", [] -> mt_bytes + | "chain_id", [] -> mt_chain_id + | "key_hash", [] -> mt_key_hash + | "contract", [ t ] -> mt_contract (mtype t) + | "address", [] -> mt_address + | "list", [ t ] -> mt_list (mtype t) + | "option", [ t ] -> mt_option (mtype t) + | "set", [ t ] -> mt_set (mtype t) + | "map", [ t1; t2 ] -> mt_map (mtype t1) (mtype t2) + | "big_map", [ t1; t2 ] -> mt_big_map (mtype t1) (mtype t2) + | "lambda", [ t1; t2 ] -> mt_lambda (mtype t1) (mtype t2) + | "operation", [] -> mt_operation + | "sapling_state", [ Int memo ] -> mt_sapling_state (int_of_string memo) + | "sapling_transaction", [ Int memo ] -> + mt_sapling_transaction (int_of_string memo) + | "never", [] -> mt_never + | "ticket", [ t ] -> mt_ticket (mtype t) + | "bls12_381_g1", [] -> mt_bls12_381_g1 + | "bls12_381_g2", [] -> mt_bls12_381_g2 + | "bls12_381_fr", [] -> mt_bls12_381_fr + | "chest_key", [] -> mt_chest_key + | "chest", [] -> mt_chest + | _ -> mk_mtype (MT_var (sprintf "Parse type error %S" (pretty "" p))) + in + List.fold_left + (fun (mt, fa) a -> + let update = function + | Some _ -> failwith "duplicate annotation" + | None -> Some (String.sub a 1 (String.length a - 1)) + in + match a.[0] with + | ':' -> { mt with annot_type = update mt.annot_type }, fa + | '@' -> { mt with annot_variable = update mt.annot_variable }, fa + | '%' -> mt, update fa + | _ -> failwith "cannot parse annotation") + (mt, None) + annotations | p -> failwith ("Parse type error " ^ pretty "" p) + ;; let rec literal x : literal = match (x : Micheline.t) with | Int i -> MLiteral.int (Bigint.of_string ~msg:"michelson" i) | Bytes s -> MLiteral.bytes s | String s -> MLiteral.string s - | Primitive {name; annotations = _; arguments} -> ( - match (name, arguments) with - | "Unit", [] -> MLiteral.unit - | "False", [] -> MLiteral.bool false - | "True", [] -> MLiteral.bool true - | "Pair", l -> ( - match List.rev l with - | [] -> assert false - | a :: l -> - List.fold_left - (fun x y -> MLiteral.pair (literal y) x) - (literal a) l) - | "None", [] -> MLiteral.none - | "Some", [x] -> MLiteral.some (literal x) - | "Left", [x] -> MLiteral.left (literal x) - | "Right", [x] -> MLiteral.right (literal x) - | "Elt", [k; v] -> MLiteral.elt (literal k) (literal v) - | "Lambda_rec", [x] -> MLiteral.lambda_rec (instruction x) - | _ -> MLiteral.instr (instruction x)) + | Primitive { name; annotations = _; arguments } -> + (match name, arguments with + | "Unit", [] -> MLiteral.unit + | "False", [] -> MLiteral.bool false + | "True", [] -> MLiteral.bool true + | "Pair", l -> + (match List.rev l with + | [] -> assert false + | a :: l -> + List.fold_left (fun x y -> MLiteral.pair (literal y) x) (literal a) l) + | "None", [] -> MLiteral.none + | "Some", [ x ] -> MLiteral.some (literal x) + | "Left", [ x ] -> MLiteral.left (literal x) + | "Right", [ x ] -> MLiteral.right (literal x) + | "Elt", [ k; v ] -> MLiteral.elt (literal k) (literal v) + | "Lambda_rec", [ x ] -> MLiteral.lambda_rec (instruction x) + | _ -> MLiteral.instr (instruction x)) | Sequence xs -> MLiteral.seq (List.map literal xs) and instruction x = - let err () = - MIerror (sprintf "Cannot parse instruction %S" (Micheline.show x)) - in - let cmp instr = MIseq [{instr = MI2 Compare}; {instr}] in + let err () = MIerror (sprintf "Cannot parse instruction %S" (Micheline.show x)) in + let cmp instr = MIseq [ { instr = MI2 Compare }; { instr } ] in let fail = - MIseq - [{instr = MIpush (mt_unit, MLiteral.unit)}; {instr = MI1_fail Failwith}] + MIseq [ { instr = MIpush (mt_unit, MLiteral.unit) }; { instr = MI1_fail Failwith } ] in let if_op instr x y = - MIseq [{instr}; {instr = MIif (instruction x, instruction y)}] + MIseq [ { instr }; { instr = MIif (instruction x, instruction y) } ] in let ifcmp_op instr x y = MIseq - [ - {instr = MI2 Compare} - ; {instr} - ; {instr = MIif (instruction x, instruction y)} + [ { instr = MI2 Compare } + ; { instr } + ; { instr = MIif (instruction x, instruction y) } ] in let assert_op instr = - MIseq [{instr}; {instr = MIif ({instr = MIseq []}, {instr = fail})}] + MIseq [ { instr }; { instr = MIif ({ instr = MIseq [] }, { instr = fail }) } ] in let assert_cmp_op instr = MIseq - [ - {instr = MI2 Compare} - ; {instr} - ; {instr = MIif ({instr = MIseq []}, {instr = fail})} + [ { instr = MI2 Compare } + ; { instr } + ; { instr = MIif ({ instr = MIseq [] }, { instr = fail }) } ] in let parse_simple_macro = function | "FAIL" -> fail - | "ASSERT" -> MIif ({instr = MIseq []}, {instr = fail}) + | "ASSERT" -> MIif ({ instr = MIseq [] }, { instr = fail }) | "CMPEQ" -> cmp (MI1 Eq) | "CMPNEQ" -> cmp (MI1 Eq) | "CMPLT" -> cmp (MI1 Lt) @@ -2869,287 +2896,276 @@ module Of_micheline = struct | "ASSERT_CMPGT" -> assert_cmp_op (MI1 Gt) | "ASSERT_CMPLE" -> assert_cmp_op (MI1 Le) | "ASSERT_CMPGE" -> assert_cmp_op (MI1 Ge) - | "ASSERT_SOME" -> MIif_none ({instr = fail}, {instr = MIseq []}) - | "ASSERT_NONE" -> MIif_none ({instr = MIseq []}, {instr = fail}) + | "ASSERT_SOME" -> MIif_none ({ instr = fail }, { instr = MIseq [] }) + | "ASSERT_NONE" -> MIif_none ({ instr = MIseq [] }, { instr = fail }) | prim when String.index_opt prim 'D' = Some 0 && String.index_opt prim 'P' = Some (String.length prim - 1) && 2 < String.length prim - && Base.String.count prim ~f:(fun c -> c = 'U') - = String.length prim - 2 -> - let n = String.length prim - 3 in - MIseq [{instr = MIdig n}; {instr = MIdup 1}; {instr = MIdug (n + 1)}] + && Base.String.count prim ~f:(fun c -> c = 'U') = String.length prim - 2 -> + let n = String.length prim - 3 in + MIseq [ { instr = MIdig n }; { instr = MIdup 1 }; { instr = MIdug (n + 1) } ] | prim when String.index_opt prim 'C' = Some 0 - && String.index_opt prim 'R' = Some (String.length prim - 1) -> ( - let l = - Base.String.fold - (String.sub prim 1 (String.length prim - 2)) - ~init:(Some []) - ~f:(fun acc c -> - match (acc, c) with - | Some acc, 'A' -> Some (A :: acc) - | Some acc, 'D' -> Some (D :: acc) - | _ -> None) - in - match l with - | Some l -> MIfield (List.rev l) - | None -> err ()) + && String.index_opt prim 'R' = Some (String.length prim - 1) -> + let l = + Base.String.fold + (String.sub prim 1 (String.length prim - 2)) + ~init:(Some []) + ~f:(fun acc c -> + match acc, c with + | Some acc, 'A' -> Some (A :: acc) + | Some acc, 'D' -> Some (D :: acc) + | _ -> None) + in + (match l with + | Some l -> MIfield (List.rev l) + | None -> err ()) | _ -> err () in let instr = match x with - | Sequence [x] -> (instruction x).instr + | Sequence [ x ] -> (instruction x).instr | Sequence xs -> MIseq (List.map instruction xs) - | Primitive {name; annotations; arguments} -> ( - match (name, arguments) with - | "RENAME", [] -> - let a = - match annotations with - | [] -> None - | [a] -> Base.String.chop_prefix ~prefix:"@" a - | _ -> assert false - in - MI1 (Rename a) - | "UNIT", [] -> MI0 Unit_ - | "EMPTY_MAP", [k; v] -> - MIpush (mt_map (mtype k) (mtype v), MLiteral.mk_map []) - | "EMPTY_SET", [t] -> MIpush (mt_set (mtype t), MLiteral.set []) - | "EMPTY_BIG_MAP", [k; v] -> MI0 (Empty_bigmap (mtype k, mtype v)) - | "DIP", [x] -> MIdip (instruction x) - | "DIP", [Int i; x] -> MIdipn (int_of_string i, instruction x) - | prim, [x] - when String.index_opt prim 'D' = Some 0 - && String.index_opt prim 'P' = Some (String.length prim - 1) - && 2 < String.length prim - && Base.String.count prim ~f:(fun c -> c = 'I') - = String.length prim - 2 -> - MIdipn (String.length prim - 2, instruction x) - | "LOOP", [x] -> MIloop (instruction x) - | "LOOP_LEFT", [x] -> MIloop_left (instruction x) - | "ITER", [x] -> MIiter (instruction x) - | "MAP", [x] -> MImap (instruction x) - | "DROP", [] -> MIdrop - | "DROP", [Int n] -> MIdropn (int_of_string n) - | "DUP", [] -> MIdup 1 - | "DUP", [Int n] -> MIdup (int_of_string n) - | "DIG", [Int i] -> MIdig (int_of_string i) - | "DUG", [Int i] -> MIdug (int_of_string i) - | "FAILWITH", [] -> MI1_fail Failwith - | "IF", [x; y] -> MIif (instruction x, instruction y) - | "IF_LEFT", [x; y] -> MIif_left (instruction x, instruction y) - | "IF_RIGHT", [x; y] -> MIif_left (instruction y, instruction x) - | "IF_SOME", [x; y] -> MIif_none (instruction y, instruction x) - | "IF_NONE", [x; y] -> MIif_none (instruction x, instruction y) - | "IF_CONS", [x; y] -> MIif_cons (instruction x, instruction y) - | "NIL", [t] -> MI0 (Nil (mtype t)) - | "CONS", [] -> MI2 Cons - | "NONE", [t] -> MI0 (None_ (mtype t)) - | "SOME", [] -> MI1 Some_ - | "PAIR", [] -> MI2 (Pair (None, None)) - | "PAIR", [Int n] -> MIpairn (int_of_string n) - | "LEFT", [t] -> MI1 (Left (None, None, mtype t)) - | "RIGHT", [t] -> MI1 (Right (None, None, mtype t)) - | "PUSH", [t; l] -> MIpush (mtype t, literal l) - | "SWAP", [] -> MIswap - | "UNPAIR", [] -> MIunpair [true; true] - | "UNPAIR", [Int n] -> - MIunpair (List.replicate (int_of_string n) true) - | "CAR", [] -> MIfield [A] - | "CDR", [] -> MIfield [D] - | "CONTRACT", [t] -> - let entrypoint = - match annotations with - | [] -> None - | entrypoint :: _ -> - Base.String.chop_prefix ~prefix:"%" entrypoint - in - MI1 (Contract (entrypoint, mtype t)) - | "VIEW", [String name; t] -> MI2 (View (name, mtype t)) - | "CAST", [t] -> - let t = mtype t in - MI1 (Cast t) - | "EXEC", [] -> MI2 Exec - | "APPLY", [] -> MI2 Apply - | "LAMBDA", [t; u; x] -> MIlambda (mtype t, mtype u, instruction x) - | "LAMBDA_REC", [t; u; x] -> - MIlambda_rec (mtype t, mtype u, instruction x) - | "EMIT", _ -> ( - match (annotations, arguments) with - | [], [] -> MI1 (Emit (None, None)) - | [annot], [] -> MI1 (Emit (Some annot, None)) - | [], [t] -> MI1 (Emit (None, Some (mtype t))) - | [annot], [t] -> MI1 (Emit (Some annot, Some (mtype t))) - | _ -> err ()) - | "CREATE_CONTRACT", [x] -> - let tparameter, tstorage, code = - if false then failwith (Micheline.show x); - match x with - | Sequence - [ - Primitive {name = "parameter"; arguments = [tparameter]} - ; Primitive {name = "storage"; arguments = [tstorage]} - ; Primitive {name = "code"; arguments = [code]} - ] -> - ( ( mtype tparameter - , None (* TODO single entrypoint annotation *) ) - , mtype tstorage - , instruction code ) - | _ -> assert false - in - MIcreate_contract - {tparameter; tstorage; code; views = (* TODO *) []} - | "SELF", [] -> - let entrypoint = - match annotations with - | [] -> None - | entrypoint :: _ -> - Base.String.chop_prefix ~prefix:"%" entrypoint - in - MI0 (Self entrypoint) - | "ADDRESS", [] -> MI1 Address - | "SELF_ADDRESS", [] -> MI0 Self_address - | "IMPLICIT_ACCOUNT", [] -> MI1 Implicit_account - | "TRANSFER_TOKENS", [] -> MI3 Transfer_tokens - | "CHECK_SIGNATURE", [] -> MI3 Check_signature - | "SET_DELEGATE", [] -> MI1 Set_delegate - | "SAPLING_EMPTY_STATE", [Int memo] -> - MI0 (Sapling_empty_state {memo = int_of_string memo}) - | "SAPLING_VERIFY_UPDATE", [] -> MI2 Sapling_verify_update - | "NEVER", [] -> MI1_fail Never - | "READ_TICKET", [] -> MI1 Read_ticket - | "TICKET", [] -> MI2 Ticket - | "TICKET_DEPRECATED", [] -> MI2 Ticket_deprecated - | "SPLIT_TICKET", [] -> MI2 Split_ticket - | "JOIN_TICKETS", [] -> MI1 Join_tickets - | "PAIRING_CHECK", [] -> MI1 Pairing_check - | "TOTAL_VOTING_POWER", [] -> MI0 Total_voting_power - | "VOTING_POWER", [] -> MI1 Voting_power - | "EQ", [] -> MI1 Eq - | "NEQ", [] -> MI1 Neq - | "LE", [] -> MI1 Le - | "LT", [] -> MI1 Lt - | "GE", [] -> MI1 Ge - | "GT", [] -> MI1 Gt - | "COMPARE", [] -> MI2 Compare - | "MUL", [] -> MI2 Mul - | "ADD", [] -> MI2 Add - | "SUB", [] -> MI2 Sub - | "EDIV", [] -> MI2 Ediv - | "NOT", [] -> MI1 Not - | "AND", [] -> MI2 And - | "OR", [] -> MI2 Or - | "LSL", [] -> MI2 Lsl - | "LSR", [] -> MI2 Lsr - | "SUB_MUTEZ", [] -> MI2 Sub_mutez - | "XOR", [] -> MI2 Xor - | "CONCAT", [] -> MIconcat1 (* Changed from MIconcat_unresolved *) - | "SLICE", [] -> MI3 Slice - | "SIZE", [] -> MI1 Size - | "GET", [] -> MI2 Get - | "GET", [Int x] -> MI1 (Getn (int_of_string x)) - | "UPDATE", [] -> MI3 Update - | "UPDATE", [Int x] -> MI2 (Updaten (int_of_string x)) - | "GET_AND_UPDATE", [] -> MI3 Get_and_update - | "OPEN_CHEST", [] -> MI3 Open_chest - | "SENDER", [] -> MI0 Sender - | "SOURCE", [] -> MI0 Source - | "AMOUNT", [] -> MI0 Amount - | "BALANCE", [] -> MI0 Balance - | "NOW", [] -> MI0 Now - | "LEVEL", [] -> MI0 Level - | "CHAIN_ID", [] -> MI0 Chain_id - | "MEM", [] -> MI2 Mem - | "HASH_KEY", [] -> MI1 Hash_key - | "BLAKE2B", [] -> MI1 Blake2b - | "SHA256", [] -> MI1 Sha256 - | "SHA512", [] -> MI1 Sha512 - | "KECCAK", [] -> MI1 Keccak - | "SHA3", [] -> MI1 Sha3 - | "ABS", [] -> MI1 Abs - | "NEG", [] -> MI1 Neg - | "INT", [] -> MI1 Int - | "NAT", [] -> MI1 Nat - | "BYTES", [] -> MI1 Bytes - | "ISNAT", [] -> MI1 IsNat - | "PACK", [] -> MI1 Pack - | "UNPACK", [t] -> MI1 (Unpack (mtype t)) - | prim, [] -> parse_simple_macro prim - | "IFEQ", [x; y] -> if_op (MI1 Eq) x y - | "IFNEQ", [x; y] -> if_op (MI1 Eq) x y - | "IFLT", [x; y] -> if_op (MI1 Lt) x y - | "IFGT", [x; y] -> if_op (MI1 Gt) x y - | "IFLE", [x; y] -> if_op (MI1 Le) x y - | "IFGE", [x; y] -> if_op (MI1 Ge) x y - | "IFCMPEQ", [x; y] -> ifcmp_op (MI1 Eq) x y - | "IFCMPNEQ", [x; y] -> ifcmp_op (MI1 Eq) x y - | "IFCMPLT", [x; y] -> ifcmp_op (MI1 Lt) x y - | "IFCMPGT", [x; y] -> ifcmp_op (MI1 Gt) x y - | "IFCMPLE", [x; y] -> ifcmp_op (MI1 Le) x y - | "IFCMPGE", [x; y] -> ifcmp_op (MI1 Ge) x y - (* TODO Macros: ASSERT_SOME, ASSERT_LEFT, ASSERT_RIGHT *) - | _ -> err ()) + | Primitive { name; annotations; arguments } -> + (match name, arguments with + | "RENAME", [] -> + let a = + match annotations with + | [] -> None + | [ a ] -> Base.String.chop_prefix ~prefix:"@" a + | _ -> assert false + in + MI1 (Rename a) + | "UNIT", [] -> MI0 Unit_ + | "EMPTY_MAP", [ k; v ] -> MIpush (mt_map (mtype k) (mtype v), MLiteral.mk_map []) + | "EMPTY_SET", [ t ] -> MIpush (mt_set (mtype t), MLiteral.set []) + | "EMPTY_BIG_MAP", [ k; v ] -> MI0 (Empty_bigmap (mtype k, mtype v)) + | "DIP", [ x ] -> MIdip (instruction x) + | "DIP", [ Int i; x ] -> MIdipn (int_of_string i, instruction x) + | prim, [ x ] + when String.index_opt prim 'D' = Some 0 + && String.index_opt prim 'P' = Some (String.length prim - 1) + && 2 < String.length prim + && Base.String.count prim ~f:(fun c -> c = 'I') = String.length prim - 2 + -> MIdipn (String.length prim - 2, instruction x) + | "LOOP", [ x ] -> MIloop (instruction x) + | "LOOP_LEFT", [ x ] -> MIloop_left (instruction x) + | "ITER", [ x ] -> MIiter (instruction x) + | "MAP", [ x ] -> MImap (instruction x) + | "DROP", [] -> MIdrop + | "DROP", [ Int n ] -> MIdropn (int_of_string n) + | "DUP", [] -> MIdup 1 + | "DUP", [ Int n ] -> MIdup (int_of_string n) + | "DIG", [ Int i ] -> MIdig (int_of_string i) + | "DUG", [ Int i ] -> MIdug (int_of_string i) + | "FAILWITH", [] -> MI1_fail Failwith + | "IF", [ x; y ] -> MIif (instruction x, instruction y) + | "IF_LEFT", [ x; y ] -> MIif_left (instruction x, instruction y) + | "IF_RIGHT", [ x; y ] -> MIif_left (instruction y, instruction x) + | "IF_SOME", [ x; y ] -> MIif_none (instruction y, instruction x) + | "IF_NONE", [ x; y ] -> MIif_none (instruction x, instruction y) + | "IF_CONS", [ x; y ] -> MIif_cons (instruction x, instruction y) + | "NIL", [ t ] -> MI0 (Nil (mtype t)) + | "CONS", [] -> MI2 Cons + | "NONE", [ t ] -> MI0 (None_ (mtype t)) + | "SOME", [] -> MI1 Some_ + | "PAIR", [] -> MI2 (Pair (None, None)) + | "PAIR", [ Int n ] -> MIpairn (int_of_string n) + | "LEFT", [ t ] -> MI1 (Left (None, None, mtype t)) + | "RIGHT", [ t ] -> MI1 (Right (None, None, mtype t)) + | "PUSH", [ t; l ] -> MIpush (mtype t, literal l) + | "SWAP", [] -> MIswap + | "UNPAIR", [] -> MIunpair [ true; true ] + | "UNPAIR", [ Int n ] -> MIunpair (List.replicate (int_of_string n) true) + | "CAR", [] -> MIfield [ A ] + | "CDR", [] -> MIfield [ D ] + | "CONTRACT", [ t ] -> + let entrypoint = + match annotations with + | [] -> None + | entrypoint :: _ -> Base.String.chop_prefix ~prefix:"%" entrypoint + in + MI1 (Contract (entrypoint, mtype t)) + | "VIEW", [ String name; t ] -> MI2 (View (name, mtype t)) + | "CAST", [ t ] -> + let t = mtype t in + MI1 (Cast t) + | "EXEC", [] -> MI2 Exec + | "APPLY", [] -> MI2 Apply + | "LAMBDA", [ t; u; x ] -> MIlambda (mtype t, mtype u, instruction x) + | "LAMBDA_REC", [ t; u; x ] -> MIlambda_rec (mtype t, mtype u, instruction x) + | "EMIT", _ -> + (match annotations, arguments with + | [], [] -> MI1 (Emit (None, None)) + | [ annot ], [] -> MI1 (Emit (Some annot, None)) + | [], [ t ] -> MI1 (Emit (None, Some (mtype t))) + | [ annot ], [ t ] -> MI1 (Emit (Some annot, Some (mtype t))) + | _ -> err ()) + | "CREATE_CONTRACT", [ x ] -> + let tparameter, tstorage, code = + if false then failwith (Micheline.show x); + match x with + | Sequence + [ Primitive { name = "parameter"; arguments = [ tparameter ] } + ; Primitive { name = "storage"; arguments = [ tstorage ] } + ; Primitive { name = "code"; arguments = [ code ] } + ] -> + ( (mtype tparameter, None (* TODO single entrypoint annotation *)) + , mtype tstorage + , instruction code ) + | _ -> assert false + in + MIcreate_contract { tparameter; tstorage; code; views = (* TODO *) [] } + | "SELF", [] -> + let entrypoint = + match annotations with + | [] -> None + | entrypoint :: _ -> Base.String.chop_prefix ~prefix:"%" entrypoint + in + MI0 (Self entrypoint) + | "ADDRESS", [] -> MI1 Address + | "SELF_ADDRESS", [] -> MI0 Self_address + | "IMPLICIT_ACCOUNT", [] -> MI1 Implicit_account + | "TRANSFER_TOKENS", [] -> MI3 Transfer_tokens + | "CHECK_SIGNATURE", [] -> MI3 Check_signature + | "SET_DELEGATE", [] -> MI1 Set_delegate + | "SAPLING_EMPTY_STATE", [ Int memo ] -> + MI0 (Sapling_empty_state { memo = int_of_string memo }) + | "SAPLING_VERIFY_UPDATE", [] -> MI2 Sapling_verify_update + | "NEVER", [] -> MI1_fail Never + | "READ_TICKET", [] -> MI1 Read_ticket + | "TICKET", [] -> MI2 Ticket + | "TICKET_DEPRECATED", [] -> MI2 Ticket_deprecated + | "SPLIT_TICKET", [] -> MI2 Split_ticket + | "JOIN_TICKETS", [] -> MI1 Join_tickets + | "PAIRING_CHECK", [] -> MI1 Pairing_check + | "TOTAL_VOTING_POWER", [] -> MI0 Total_voting_power + | "VOTING_POWER", [] -> MI1 Voting_power + | "EQ", [] -> MI1 Eq + | "NEQ", [] -> MI1 Neq + | "LE", [] -> MI1 Le + | "LT", [] -> MI1 Lt + | "GE", [] -> MI1 Ge + | "GT", [] -> MI1 Gt + | "COMPARE", [] -> MI2 Compare + | "MUL", [] -> MI2 Mul + | "ADD", [] -> MI2 Add + | "SUB", [] -> MI2 Sub + | "EDIV", [] -> MI2 Ediv + | "NOT", [] -> MI1 Not + | "AND", [] -> MI2 And + | "OR", [] -> MI2 Or + | "LSL", [] -> MI2 Lsl + | "LSR", [] -> MI2 Lsr + | "SUB_MUTEZ", [] -> MI2 Sub_mutez + | "XOR", [] -> MI2 Xor + | "CONCAT", [] -> MIconcat1 (* Changed from MIconcat_unresolved *) + | "SLICE", [] -> MI3 Slice + | "SIZE", [] -> MI1 Size + | "GET", [] -> MI2 Get + | "GET", [ Int x ] -> MI1 (Getn (int_of_string x)) + | "UPDATE", [] -> MI3 Update + | "UPDATE", [ Int x ] -> MI2 (Updaten (int_of_string x)) + | "GET_AND_UPDATE", [] -> MI3 Get_and_update + | "OPEN_CHEST", [] -> MI3 Open_chest + | "SENDER", [] -> MI0 Sender + | "SOURCE", [] -> MI0 Source + | "AMOUNT", [] -> MI0 Amount + | "BALANCE", [] -> MI0 Balance + | "NOW", [] -> MI0 Now + | "LEVEL", [] -> MI0 Level + | "CHAIN_ID", [] -> MI0 Chain_id + | "MEM", [] -> MI2 Mem + | "HASH_KEY", [] -> MI1 Hash_key + | "BLAKE2B", [] -> MI1 Blake2b + | "SHA256", [] -> MI1 Sha256 + | "SHA512", [] -> MI1 Sha512 + | "KECCAK", [] -> MI1 Keccak + | "SHA3", [] -> MI1 Sha3 + | "ABS", [] -> MI1 Abs + | "NEG", [] -> MI1 Neg + | "INT", [] -> MI1 Int + | "NAT", [] -> MI1 Nat + | "BYTES", [] -> MI1 Bytes + | "ISNAT", [] -> MI1 IsNat + | "PACK", [] -> MI1 Pack + | "UNPACK", [ t ] -> MI1 (Unpack (mtype t)) + | prim, [] -> parse_simple_macro prim + | "IFEQ", [ x; y ] -> if_op (MI1 Eq) x y + | "IFNEQ", [ x; y ] -> if_op (MI1 Eq) x y + | "IFLT", [ x; y ] -> if_op (MI1 Lt) x y + | "IFGT", [ x; y ] -> if_op (MI1 Gt) x y + | "IFLE", [ x; y ] -> if_op (MI1 Le) x y + | "IFGE", [ x; y ] -> if_op (MI1 Ge) x y + | "IFCMPEQ", [ x; y ] -> ifcmp_op (MI1 Eq) x y + | "IFCMPNEQ", [ x; y ] -> ifcmp_op (MI1 Eq) x y + | "IFCMPLT", [ x; y ] -> ifcmp_op (MI1 Lt) x y + | "IFCMPGT", [ x; y ] -> ifcmp_op (MI1 Gt) x y + | "IFCMPLE", [ x; y ] -> ifcmp_op (MI1 Le) x y + | "IFCMPGE", [ x; y ] -> ifcmp_op (MI1 Ge) x y + (* TODO Macros: ASSERT_SOME, ASSERT_LEFT, ASSERT_RIGHT *) + | _ -> err ()) | _ -> err () in - {instr} + { instr } + ;; let contract = let read_element (p, s, c, vs) = function - | Micheline.Primitive {name = "parameter"; arguments} -> ( - match (p, arguments) with - | None, [parameter] -> - let parameter = mtype_annotated parameter in - (Some parameter, s, c, vs) - | None, _ -> failwith "ill-formed 'parameter'" - | Some _, _ -> failwith "'parameter' defined twice") - | Primitive {name = "storage"; arguments} -> ( - match (s, arguments) with - | None, [storage] -> - let storage = mtype storage in - (p, Some storage, c, vs) - | None, _ -> failwith "ill-formed 'storage'" - | Some _, _ -> failwith "'storage' defined twice") - | Primitive {name = "code"; arguments} -> ( - match (c, arguments) with - | None, [code] -> - let code = instruction code in - (p, s, Some code, vs) - | None, _ -> failwith "ill-formed 'code'" - | Some _, _ -> failwith "'code' defined twice") - | Primitive {name = "view"; arguments} -> ( - match arguments with - | [String name; tin; tout; code] -> - let tin = mtype tin in - let tout = mtype tout in - let code = instruction code in - let (view : instr view) = - { - name - ; pure = true - ; doc = "" - ; tparameter = Some tin - ; treturn = tout - ; onchain_code = Some code - ; offchain_code = code - } - in - (p, s, c, view :: vs) - | _ -> failwith "ill-formed 'view'") - | Primitive {name} -> - failwith ("ill-formed contract: unexpected '" ^ name ^ "'") + | Micheline.Primitive { name = "parameter"; arguments } -> + (match p, arguments with + | None, [ parameter ] -> + let parameter = mtype_annotated parameter in + Some parameter, s, c, vs + | None, _ -> failwith "ill-formed 'parameter'" + | Some _, _ -> failwith "'parameter' defined twice") + | Primitive { name = "storage"; arguments } -> + (match s, arguments with + | None, [ storage ] -> + let storage = mtype storage in + p, Some storage, c, vs + | None, _ -> failwith "ill-formed 'storage'" + | Some _, _ -> failwith "'storage' defined twice") + | Primitive { name = "code"; arguments } -> + (match c, arguments with + | None, [ code ] -> + let code = instruction code in + p, s, Some code, vs + | None, _ -> failwith "ill-formed 'code'" + | Some _, _ -> failwith "'code' defined twice") + | Primitive { name = "view"; arguments } -> + (match arguments with + | [ String name; tin; tout; code ] -> + let tin = mtype tin in + let tout = mtype tout in + let code = instruction code in + let (view : instr view) = + { name + ; pure = true + ; doc = "" + ; tparameter = Some tin + ; treturn = tout + ; onchain_code = Some code + ; offchain_code = code + } + in + p, s, c, view :: vs + | _ -> failwith "ill-formed 'view'") + | Primitive { name } -> failwith ("ill-formed contract: unexpected '" ^ name ^ "'") | _ -> failwith "ill-formed contract: expected primitive" in function - | Micheline.Sequence s -> ( - match List.fold_left read_element (None, None, None, []) s with - | None, _, _, _ -> failwith "ill-formed contract: missing 'parameter'" - | _, None, _, _ -> failwith "ill-formed contract: missing 'storage'" - | _, _, None, _ -> failwith "ill-formed contract: missing 'code'" - | Some tparameter, Some tstorage, Some code, views -> - let views = List.rev views in - ({contract = {tparameter; tstorage; code; views}; storage = None} - : instance)) + | Micheline.Sequence s -> + (match List.fold_left read_element (None, None, None, []) s with + | None, _, _, _ -> failwith "ill-formed contract: missing 'parameter'" + | _, None, _, _ -> failwith "ill-formed contract: missing 'storage'" + | _, _, None, _ -> failwith "ill-formed contract: missing 'code'" + | Some tparameter, Some tstorage, Some code, views -> + let views = List.rev views in + ({ contract = { tparameter; tstorage; code; views }; storage = None } : instance)) | _ -> failwith "ill-formed contract: not a sequence" + ;; end module To_micheline = struct @@ -3157,25 +3173,26 @@ module To_micheline = struct let mtype ?annot_field = cata_mtype ~annot_field (fun ?annot_type ?annot_variable t ~annot_field -> - let annotations = - let get pref = Option.map (( ^ ) pref) in - List.somes - [get "%" annot_field; get ":" annot_type; get "@" annot_variable] - in - let prim = primitive ~annotations in - match t with - | MT0 t -> - let t, memo = string_of_type0 t in - Option.cata (prim t []) (fun x -> prim t [Int x]) memo - | MT1 (t, t1) -> prim (string_of_type1 t) [t1 ~annot_field:None] - | MT2 (t, t1, t2) -> - let t, a1, a2 = string_of_type2 t in - prim t [t1 ~annot_field:a1; t2 ~annot_field:a2] - | MT_var msg -> - primitive "ERROR" - [Format.kasprintf string "Cannot compile missing type: %s" msg]) - - let dip_seq i = primitive "DIP" [sequence i] + let annotations = + let get pref = Option.map (( ^ ) pref) in + List.somes [ get "%" annot_field; get ":" annot_type; get "@" annot_variable ] + in + let prim = primitive ~annotations in + match t with + | MT0 t -> + let t, memo = string_of_type0 t in + Option.cata (prim t []) (fun x -> prim t [ Int x ]) memo + | MT1 (t, t1) -> prim (string_of_type1 t) [ t1 ~annot_field:None ] + | MT2 (t, t1, t2) -> + let t, a1, a2 = string_of_type2 t in + prim t [ t1 ~annot_field:a1; t2 ~annot_field:a2 ] + | MT_var msg -> + primitive + "ERROR" + [ Format.kasprintf string "Cannot compile missing type: %s" msg ]) + ;; + + let dip_seq i = primitive "DIP" [ sequence i ] let rec c_ad_r s = (* @@ -3187,9 +3204,8 @@ module To_micheline = struct | 'A' -> primitive "CAR" [] :: c_ad_r (Base.String.drop_prefix s 1) | 'D' -> primitive "CDR" [] :: c_ad_r (Base.String.drop_prefix s 1) | exception _ -> [] - | other -> - Format.kasprintf failwith "c_ad_r macro: wrong char: '%c' (of %S)" other - s + | other -> Format.kasprintf failwith "c_ad_r macro: wrong char: '%c' (of %S)" other s + ;; let rec set_c_ad_r s = (* @@ -3204,31 +3220,25 @@ module To_micheline = struct *) match s.[0] with | 'A' when String.length s > 1 -> - [ - primitive "DUP" [] - ; dip_seq - (primitive "CAR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) - ; primitive "CDR" [] - ; primitive "SWAP" [] - ; primitive "PAIR" [] - ] - | 'A' -> [primitive "CDR" []; primitive "SWAP" []; primitive "PAIR" []] + [ primitive "DUP" [] + ; dip_seq (primitive "CAR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) + ; primitive "CDR" [] + ; primitive "SWAP" [] + ; primitive "PAIR" [] + ] + | 'A' -> [ primitive "CDR" []; primitive "SWAP" []; primitive "PAIR" [] ] | 'D' when String.length s > 1 -> - [ - primitive "DUP" [] - ; dip_seq - (primitive "CDR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) - ; primitive "CAR" [] - ; primitive "PAIR" [] - ] - | 'D' -> [primitive "CAR" []; primitive "PAIR" []] - | exception _ -> - Format.kasprintf failwith "set_c_r_macro: called with no chars: S" s - | other -> - Format.kasprintf failwith "set_c_r_macro: wrong char: '%c' (of %S)" - other s - - let rec literal ~protocol {literal = l} = + [ primitive "DUP" [] + ; dip_seq (primitive "CDR" [] :: set_c_ad_r (Base.String.drop_prefix s 1)) + ; primitive "CAR" [] + ; primitive "PAIR" [] + ] + | 'D' -> [ primitive "CAR" []; primitive "PAIR" [] ] + | exception _ -> Format.kasprintf failwith "set_c_r_macro: called with no chars: S" s + | other -> Format.kasprintf failwith "set_c_r_macro: wrong char: '%c' (of %S)" other s + ;; + + let rec literal ~protocol { literal = l } = let literal = literal ~protocol in let instruction = instruction ~protocol in match l with @@ -3238,107 +3248,102 @@ module To_micheline = struct | String s -> string s | Unit -> primitive "Unit" [] | Bytes b -> bytes b - | Pair (left, right) -> primitive "Pair" [literal left; literal right] + | Pair (left, right) -> primitive "Pair" [ literal left; literal right ] | None_ -> primitive "None" [] - | Some_ l -> primitive "Some" [literal l] - | Left e -> primitive "Left" [literal e] - | Right e -> primitive "Right" [literal e] + | Some_ l -> primitive "Some" [ literal l ] + | Left e -> primitive "Left" [ literal e ] + | Right e -> primitive "Right" [ literal e ] | Seq xs -> xs |> List.map literal |> sequence - | Elt (k, v) -> primitive "Elt" [literal k; literal v] + | Elt (k, v) -> primitive "Elt" [ literal k; literal v ] | Instr x -> sequence (instruction x) | Lambda_rec x -> primitive "Lambda_rec" (instruction x) | AnyMap xs -> - let xs = List.map (fun (k, v) -> {literal = Elt (k, v)}) xs in - literal {literal = Seq xs} - | Constant hash -> primitive "constant" [string hash] + let xs = List.map (fun (k, v) -> { literal = Elt (k, v) }) xs in + literal { literal = Seq xs } + | Constant hash -> primitive "constant" [ string hash ] and instruction ~protocol (the_instruction : instr) = let literal = literal ~protocol in let instruction = instruction ~protocol in - let prim0 ?annotations n = [primitive ?annotations n []] in - let primn ?annotations n l = [primitive ?annotations n l] in + let prim0 ?annotations n = [ primitive ?annotations n [] ] in + let primn ?annotations n l = [ primitive ?annotations n l ] in let rec_instruction instr = Micheline.sequence (instruction instr) in match the_instruction.instr with - | MIerror s -> primn "ERROR" [string s] + | MIerror s -> primn "ERROR" [ string s ] | MIcomment _comment -> - [] - (* + [] + (* [ primitive "PUSH" [primitive "string" []; string comment] ; primitive "DROP" [] ] *) - | MIdip instr -> primn "DIP" [rec_instruction instr] - | MIdipn (n, instr) -> - primn "DIP" [int (string_of_int n); rec_instruction instr] - | MIdig n -> primn "DIG" [int (string_of_int n)] - | MIdug n -> primn "DUG" [int (string_of_int n)] + | MIdip instr -> primn "DIP" [ rec_instruction instr ] + | MIdipn (n, instr) -> primn "DIP" [ int (string_of_int n); rec_instruction instr ] + | MIdig n -> primn "DIG" [ int (string_of_int n) ] + | MIdug n -> primn "DUG" [ int (string_of_int n) ] | MIdup 1 -> primn "DUP" [] - | MIdup n -> primn "DUP" [int (string_of_int n)] - | MIunpair [true; true] -> primn "UNPAIR" [] - | MIunpair n -> primn "UNPAIR" [int (unpair_arg n)] - | MIpairn n -> primn "PAIR" [int (string_of_int n)] - | MI1 (Getn n) -> primn "GET" [int (string_of_int n)] - | MI2 (Updaten n) -> primn "UPDATE" [int (string_of_int n)] - | MIdropn n -> primn "DROP" [int (string_of_int n)] - | MIloop instr -> primn "LOOP" [rec_instruction instr] - | MIloop_left instr -> primn "LOOP_LEFT" [rec_instruction instr] - | MIiter instr -> primn "ITER" [rec_instruction instr] - | MImap instr -> primn "MAP" [rec_instruction instr] + | MIdup n -> primn "DUP" [ int (string_of_int n) ] + | MIunpair [ true; true ] -> primn "UNPAIR" [] + | MIunpair n -> primn "UNPAIR" [ int (unpair_arg n) ] + | MIpairn n -> primn "PAIR" [ int (string_of_int n) ] + | MI1 (Getn n) -> primn "GET" [ int (string_of_int n) ] + | MI2 (Updaten n) -> primn "UPDATE" [ int (string_of_int n) ] + | MIdropn n -> primn "DROP" [ int (string_of_int n) ] + | MIloop instr -> primn "LOOP" [ rec_instruction instr ] + | MIloop_left instr -> primn "LOOP_LEFT" [ rec_instruction instr ] + | MIiter instr -> primn "ITER" [ rec_instruction instr ] + | MImap instr -> primn "MAP" [ rec_instruction instr ] | MIseq ils -> List.concat_map instruction ils - | MIif (t, e) -> primn "IF" [rec_instruction t; rec_instruction e] - | MIif_left (t, e) -> primn "IF_LEFT" [rec_instruction t; rec_instruction e] - | MIif_none (t, e) -> primn "IF_NONE" [rec_instruction t; rec_instruction e] - | MIif_cons (t, e) -> primn "IF_CONS" [rec_instruction t; rec_instruction e] - | MIpush (mt, lit) -> primn "PUSH" [mtype mt; literal lit] - | MI0 (Self (Some entrypoint)) -> - primn ~annotations:["%" ^ entrypoint] "SELF" [] - | MI2 (Pair (a1, a2)) -> - primn ~annotations:(two_field_annots (a1, a2)) "PAIR" [] + | MIif (t, e) -> primn "IF" [ rec_instruction t; rec_instruction e ] + | MIif_left (t, e) -> primn "IF_LEFT" [ rec_instruction t; rec_instruction e ] + | MIif_none (t, e) -> primn "IF_NONE" [ rec_instruction t; rec_instruction e ] + | MIif_cons (t, e) -> primn "IF_CONS" [ rec_instruction t; rec_instruction e ] + | MIpush (mt, lit) -> primn "PUSH" [ mtype mt; literal lit ] + | MI0 (Self (Some entrypoint)) -> primn ~annotations:[ "%" ^ entrypoint ] "SELF" [] + | MI2 (Pair (a1, a2)) -> primn ~annotations:(two_field_annots (a1, a2)) "PAIR" [] | MI1 (Right (a1, a2, mty)) -> - primn ~annotations:(two_field_annots (a1, a2)) "RIGHT" [mtype mty] + primn ~annotations:(two_field_annots (a1, a2)) "RIGHT" [ mtype mty ] | MI1 (Left (a1, a2, mty)) -> - primn ~annotations:(two_field_annots (a1, a2)) "LEFT" [mtype mty] - | MI0 (None_ mty) -> primn "NONE" [mtype mty] - | MI0 (Nil mty) -> primn "NIL" [mtype mty] - | MI0 (Empty_set mty) -> primn "EMPTY_SET" [mtype mty] - | MI0 (Empty_map (k, v)) -> primn "EMPTY_MAP" [mtype k; mtype v] - | MI0 (Empty_bigmap (k, v)) -> primn "EMPTY_BIG_MAP" [mtype k; mtype v] - | MI1 (Contract (None, mty)) -> primn "CONTRACT" [mtype mty] + primn ~annotations:(two_field_annots (a1, a2)) "LEFT" [ mtype mty ] + | MI0 (None_ mty) -> primn "NONE" [ mtype mty ] + | MI0 (Nil mty) -> primn "NIL" [ mtype mty ] + | MI0 (Empty_set mty) -> primn "EMPTY_SET" [ mtype mty ] + | MI0 (Empty_map (k, v)) -> primn "EMPTY_MAP" [ mtype k; mtype v ] + | MI0 (Empty_bigmap (k, v)) -> primn "EMPTY_BIG_MAP" [ mtype k; mtype v ] + | MI1 (Contract (None, mty)) -> primn "CONTRACT" [ mtype mty ] | MI1 (Contract (Some entrypoint, mty)) -> - primn ~annotations:["%" ^ entrypoint] "CONTRACT" [mtype mty] - | MI2 (View (name, mty)) -> primn "VIEW" [string name; mtype mty] - | MI1 (Cast t) -> primn "CAST" [mtype t] + primn ~annotations:[ "%" ^ entrypoint ] "CONTRACT" [ mtype mty ] + | MI2 (View (name, mty)) -> primn "VIEW" [ string name; mtype mty ] + | MI1 (Cast t) -> primn "CAST" [ mtype t ] | MI1 (Rename None) -> primn "RENAME" [] - | MI1 (Rename (Some a)) -> primn "RENAME" ~annotations:["@" ^ a] [] - | MIlambda (t1, t2, b) -> - primn "LAMBDA" [mtype t1; mtype t2; rec_instruction b] + | MI1 (Rename (Some a)) -> primn "RENAME" ~annotations:[ "@" ^ a ] [] + | MIlambda (t1, t2, b) -> primn "LAMBDA" [ mtype t1; mtype t2; rec_instruction b ] | MIlambda_rec (t1, t2, b) -> - primn "LAMBDA_REC" [mtype t1; mtype t2; rec_instruction b] + primn "LAMBDA_REC" [ mtype t1; mtype t2; rec_instruction b ] | MI1 (Emit (tag, ty)) -> - let annotations = - match tag with - | None -> [] - | Some tag -> [tag] - in - let ty = - match ty with - | None -> [] - | Some ty -> [mtype ty] - in - primn ~annotations "EMIT" ty - | MI1 (Unpack mty) -> primn "UNPACK" [mtype mty] + let annotations = + match tag with + | None -> [] + | Some tag -> [ tag ] + in + let ty = + match ty with + | None -> [] + | Some ty -> [ mtype ty ] + in + primn ~annotations "EMIT" ty + | MI1 (Unpack mty) -> primn "UNPACK" [ mtype mty ] | MIfield op -> c_ad_r (string_of_ad_path op) | MIsetField op -> set_c_ad_r (string_of_ad_path op) - | MIcreate_contract - {tparameter = tparameter, annot_field; tstorage; code; views} -> - primn "CREATE_CONTRACT" - [ - sequence - (primn "parameter" [mtype ?annot_field tparameter] - @ primn "storage" [mtype tstorage] - @ primn "code" [rec_instruction code] - @ List.concat_map (view ~protocol) views) - ] - | MI0 (Sapling_empty_state {memo}) -> - primn "SAPLING_EMPTY_STATE" [int (string_of_int memo)] + | MIcreate_contract { tparameter = tparameter, annot_field; tstorage; code; views } -> + primn + "CREATE_CONTRACT" + [ sequence + (primn "parameter" [ mtype ?annot_field tparameter ] + @ primn "storage" [ mtype tstorage ] + @ primn "code" [ rec_instruction code ] + @ List.concat_map (view ~protocol) views) + ] + | MI0 (Sapling_empty_state { memo }) -> + primn "SAPLING_EMPTY_STATE" [ int (string_of_int memo) ] | ( MI0 ( Sender | Source @@ -3414,24 +3419,25 @@ module To_micheline = struct | Transfer_tokens | Check_signature | Open_chest ) - | MIdrop | MIswap | MImich _ | MIconcat1 | MIconcat2 | MIconcat_unresolved ) as simple -> ( - try prim0 (name_of_instr_exn ~protocol simple) - with _ -> [sequence [primitive "ERROR-NOT-SIMPLE" []]]) + | MIdrop | MIswap | MImich _ | MIconcat1 | MIconcat2 | MIconcat_unresolved ) as + simple -> + (try prim0 (name_of_instr_exn ~protocol simple) with + | _ -> [ sequence [ primitive "ERROR-NOT-SIMPLE" [] ] ]) - and view ~protocol {name; tparameter; treturn; onchain_code} = + and view ~protocol { name; tparameter; treturn; onchain_code } = let open Micheline in match onchain_code with | None -> [] | Some code -> - [ - primitive "view" - [ - literal ~protocol {literal = String name} - ; mtype (Option.default mt_unit tparameter) - ; mtype treturn - ; sequence (instruction ~protocol code) - ] - ] + [ primitive + "view" + [ literal ~protocol { literal = String name } + ; mtype (Option.default mt_unit tparameter) + ; mtype treturn + ; sequence (instruction ~protocol code) + ] + ] + ;; end let count_bigmaps = @@ -3439,52 +3445,54 @@ let count_bigmaps = let f_tliteral ~t literal = let i = match t with - | Ok {mt = MT2 (Big_map, _, _)} -> 1 + | Ok { mt = MT2 (Big_map, _, _) } -> 1 | _ -> 0 in fold_literal_f ( + ) ( + ) i literal in - cata_tliteral {f_tinstr; f_tliteral} + cata_tliteral { f_tinstr; f_tliteral } +;; let unexpected_final_stack_error = "Unexpected final stack" -let erase_types_contract {tparameter; tstorage; code; views} = +let erase_types_contract { tparameter; tstorage; code; views } = let code = erase_types_instr code in let views = List.map (map_view erase_types_instr) views in - ({tparameter; tstorage; code; views} : contract) + ({ tparameter; tstorage; code; views } : contract) +;; -let erase_types_instance ({contract; storage} : tinstance) : instance = +let erase_types_instance ({ contract; storage } : tinstance) : instance = let contract = erase_types_contract contract in let storage = Option.map erase_types_literal storage in - {contract; storage} + { contract; storage } +;; -let string_of_tliteral ~protocol x = - string_of_literal ~protocol (erase_types_literal x) +let string_of_tliteral ~protocol x = string_of_literal ~protocol (erase_types_literal x) -let typecheck_contract ~protocol - ({tparameter; tstorage; code; views} : contract) = +let typecheck_contract ~protocol ({ tparameter; tstorage; code; views } : contract) = let code = - typecheck_instr ~protocol ~tparameter + typecheck_instr + ~protocol + ~tparameter (initial_stack ~tparameter:(fst tparameter) ~tstorage) code in - let typecheck_view ({tparameter; onchain_code; offchain_code} as v) = + let typecheck_view ({ tparameter; onchain_code; offchain_code } as v) = let check offchain code = let tparameter, stack = match tparameter with | None -> - let stack = - if offchain - then Stack_ok [{tstorage with annot_variable = Some "storage"}] - else initial_stack ~tparameter:mt_unit ~tstorage - in - (mt_unit, stack) - | Some tparameter -> (tparameter, initial_stack ~tparameter ~tstorage) + let stack = + if offchain + then Stack_ok [ { tstorage with annot_variable = Some "storage" } ] + else initial_stack ~tparameter:mt_unit ~tstorage + in + mt_unit, stack + | Some tparameter -> tparameter, initial_stack ~tparameter ~tstorage in typecheck_instr ~protocol ~tparameter:(tparameter, None) stack code in - { - v with + { v with onchain_code = Option.map (check false) onchain_code ; offchain_code = (check true) offchain_code } @@ -3492,49 +3500,43 @@ let typecheck_contract ~protocol let views = List.map typecheck_view views in let code = match code.stack_out with - | Ok (Stack_ok [{mt = MT2 (Pair _, fst, snd)}]) - when unifiable_types fst (mt_list mt_operation) - && unifiable_types snd tstorage -> code + | Ok (Stack_ok [ { mt = MT2 (Pair _, fst, snd) } ]) + when unifiable_types fst (mt_list mt_operation) && unifiable_types snd tstorage -> + code | Ok Stack_failed -> code | Ok _ -> - let msg = unexpected_final_stack_error in - let err = - { - tinstr = MIerror msg - ; stack_in = code.stack_in - ; stack_out = code.stack_out - } - in - seq_snoc code err + let msg = unexpected_final_stack_error in + let err = + { tinstr = MIerror msg; stack_in = code.stack_in; stack_out = code.stack_out } + in + seq_snoc code err | Error _ -> code in - {tparameter; tstorage; code; views} + { tparameter; tstorage; code; views } +;; -let typecheck_instance ~protocol ({contract; storage} : instance) : tinstance = - let ({tparameter; tstorage} as contract) = - typecheck_contract ~protocol contract - in - let storage = - Option.map (typecheck_literal ~protocol ~tparameter tstorage) storage - in - {contract; storage} +let typecheck_instance ~protocol ({ contract; storage } : instance) : tinstance = + let ({ tparameter; tstorage } as contract) = typecheck_contract ~protocol contract in + let storage = Option.map (typecheck_literal ~protocol ~tparameter tstorage) storage in + { contract; storage } +;; -let has_error_tinstance ~accept_missings - {contract = {tparameter; tstorage; code; views}} = +let has_error_tinstance + ~accept_missings + { contract = { tparameter; tstorage; code; views } } + = let has_missing_type ~path t = if accept_missings then [] else has_missing_type ~path t in let errors = - let has_error_view {name; tparameter; treturn; onchain_code; offchain_code} - = + let has_error_view { name; tparameter; treturn; onchain_code; offchain_code } = Option.cata [] (has_error ~path:name ~accept_missings) onchain_code @ has_error ~path:name ~accept_missings offchain_code @ Option.cata [] (has_missing_type ~path:name) tparameter @ has_missing_type ~path:name treturn in let e = - has_error ~path:"code" ~accept_missings code - @ List.concat_map has_error_view views + has_error ~path:"code" ~accept_missings code @ List.concat_map has_error_view views in e @ has_missing_type ~path:"storage" tstorage @@ -3546,36 +3548,39 @@ let has_error_tinstance ~accept_missings | [] -> List.rev acc in clean [] errors +;; -let to_micheline_tinstance ~protocol - {contract = {tstorage; tparameter = tparameter, annot_field; code; views}} = +let to_micheline_tinstance + ~protocol + { contract = { tstorage; tparameter = tparameter, annot_field; code; views } } + = let open Micheline in let erase_types_from_instr code = match To_micheline.instruction ~protocol (erase_types_instr code) with - | [Sequence _] as l -> l - | l -> [sequence l] + | [ Sequence _ ] as l -> l + | l -> [ sequence l ] in sequence - ([ - primitive "storage" [To_micheline.mtype tstorage] - ; primitive "parameter" [To_micheline.mtype ?annot_field tparameter] + ([ primitive "storage" [ To_micheline.mtype tstorage ] + ; primitive "parameter" [ To_micheline.mtype ?annot_field tparameter ] ; primitive "code" (erase_types_from_instr code) ] @ List.concat_map (To_micheline.view ~protocol) (List.map (map_view erase_types_instr) views)) +;; -let display_tinstance ~protocol {contract = {tstorage; tparameter; code; views}} - = +let display_tinstance ~protocol { contract = { tstorage; tparameter; code; views } } = let display_instr = display_tinstr ~show_stack:true ~new_line:true 2 in - sprintf "parameter %s;\nstorage %s;\ncode\n%s;%s" + sprintf + "parameter %s;\nstorage %s;\ncode\n%s;%s" (string_of_tparameter ~html:false tparameter) (string_of_mtype ~protect:() ~html:false tstorage) (display_instr ~protocol code) (String.concat "" (List.map (display_view (display_instr ~protocol)) views)) +;; -let render_tinstance ~protocol {contract = {tstorage; tparameter; code; views}} - = +let render_tinstance ~protocol { contract = { tstorage; tparameter; code; views } } = sprintf "parameter %s;
storage   %s;
code
%s;
%s" @@ -3583,22 +3588,26 @@ let render_tinstance ~protocol {contract = {tstorage; tparameter; code; views}} (string_of_mtype ~protect:() ~html:true tstorage) (render_tinstr ~protocol ~show_stack:true 2 code) (List.fold_left - (fun acc {name; tparameter; treturn; onchain_code} -> + (fun acc { name; tparameter; treturn; onchain_code } -> match onchain_code with | None -> acc | Some code -> - sprintf - "%s
view
\"%s\" %s %s
%s;
" - acc name - (string_of_mtype ~protect:() ~html:true - (Option.default mt_unit tparameter)) - (string_of_mtype ~protect:() ~html:true treturn) - (render_tinstr ~protocol ~show_stack:true 2 code)) - "" views) - -let render_tinstance_no_types ~protocol - {contract = {tstorage; tparameter; code; views}} = + sprintf + "%s
view
\"%s\" %s %s
%s;
" + acc + name + (string_of_mtype ~protect:() ~html:true (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:true treturn) + (render_tinstr ~protocol ~show_stack:true 2 code)) + "" + views) +;; + +let render_tinstance_no_types + ~protocol + { contract = { tstorage; tparameter; code; views } } + = sprintf "parameter %s;
storage   %s;
code
%s;
%s" @@ -3606,25 +3615,28 @@ let render_tinstance_no_types ~protocol (string_of_mtype ~protect:() ~html:true tstorage) (render_tinstr ~protocol ~show_stack:false 2 code) (List.fold_left - (fun acc {name; tparameter; treturn; onchain_code} -> + (fun acc { name; tparameter; treturn; onchain_code } -> match onchain_code with | None -> acc | Some code -> - sprintf - "%s
view
\"%s\" %s %s
%s;
" - acc name - (string_of_mtype ~protect:() ~html:true - (Option.default mt_unit tparameter)) - (string_of_mtype ~protect:() ~html:true treturn) - (render_tinstr ~protocol ~show_stack:false 2 code)) - "" views) - -let profile_of_arity (m, n) = (m, Some (n - m)) + sprintf + "%s
view
\"%s\" %s %s
%s;
" + acc + name + (string_of_mtype ~protect:() ~html:true (Option.default mt_unit tparameter)) + (string_of_mtype ~protect:() ~html:true treturn) + (render_tinstr ~protocol ~show_stack:false 2 code)) + "" + views) +;; + +let profile_of_arity (m, n) = m, Some (n - m) let arity_of_profile = function - | m, None -> (m, None) - | m, Some d -> (m, Some (m + d)) + | m, None -> m, None + | m, Some d -> m, Some (m + d) +;; let profile ~protocol = let open Result in @@ -3635,9 +3647,8 @@ let profile ~protocol = in let if_some d x = Option.map (fun _ -> x) d in let same x y = - match (x, y) with - | Some x, Some y -> - if x = y then return (Some x) else error "profile: unequal d" + match x, y with + | Some x, Some y -> if x = y then return (Some x) else error "profile: unequal d" | None, Some y -> return (Some y) | Some x, None -> return (Some x) | None, None -> return None @@ -3651,93 +3662,85 @@ let profile ~protocol = | MIdip (p, d) -> return (p + 1, d) | MIdipn (i, (p, d)) -> return (p + i, d) | MIloop (p, d) -> - let* () = d =?= 1 in - return (p + 1, if_some d (-1)) + let* () = d =?= 1 in + return (p + 1, if_some d (-1)) | MIloop_left (p, d) -> - let* () = d =?= 1 in - return (max 1 p, if_some d 0) + let* () = d =?= 1 in + return (max 1 p, if_some d 0) | MIiter (p, d) -> - let* () = d =?= -1 in - return (p, Some (-1)) + let* () = d =?= -1 in + return (p, Some (-1)) | MImap (p, d) -> - let* () = d =?= 0 in - return (p, if_some d 0) + let* () = d =?= 0 in + return (p, if_some d 0) | MIdig n | MIdug n -> return (n + 1, Some 0) | MIif ((p1, d1), (p2, d2)) -> - let* d = same d1 d2 in - return (max p1 p2 + 1, pred d) + let* d = same d1 d2 in + return (max p1 p2 + 1, pred d) | MIif_none ((p1, d1), (p2, d2)) -> - let* d = same (pred d1) d2 in - return (max (p1 + 1) p2, d) + let* d = same (pred d1) d2 in + return (max (p1 + 1) p2, d) | MIif_left ((p1, d1), (p2, d2)) -> - let* d = same d1 d2 in - return (max p1 p2, d) + let* d = same d1 d2 in + return (max p1 p2, d) | MIif_cons ((p1, d1), (p2, d2)) -> - let* d = same (succ d1) (pred d2) in - return (max (p1 + 1) (p2 - 1), d) + let* d = same (succ d1) (pred d2) in + return (max (p1 + 1) (p2 - 1), d) | MIseq xs -> - let f = function - | _, Error e -> Error e - | (p1, None), _ -> return (p1, None) - (* TODO Fix the compiler/rewriter such that they never emit + let f = function + | _, Error e -> Error e + | (p1, None), _ -> return (p1, None) + (* TODO Fix the compiler/rewriter such that they never emit instructions after FAILWITH and assert false here. *) - | (p1, Some d1), Ok (p2, Some d2) -> - return (max p1 (p2 - d1), Some (d1 + d2)) - | (p1, Some d1), Ok (p2, None) -> return (max p1 (p2 - d1), None) - in - List.fold_right (curry f) xs (return (0, Some 0)) + | (p1, Some d1), Ok (p2, Some d2) -> return (max p1 (p2 - d1), Some (d1 + d2)) + | (p1, Some d1), Ok (p2, None) -> return (max p1 (p2 - d1), None) + in + List.fold_right (curry f) xs (return (0, Some 0)) | MIcomment _ -> return (0, Some 0) | MIlambda _ -> return (0, Some 1) | MIlambda_rec _ -> return (0, Some 1) | MIconcat_unresolved -> failwith "profile: CONCAT arity undetermined" | MIerror _ -> return (0, Some 0) - | i -> ( - match spec_of_instr ~protocol i with - | {arities = Some a} -> return (profile_of_arity a) - | _ -> assert false) + | i -> + (match spec_of_instr ~protocol i with + | { arities = Some a } -> return (profile_of_arity a) + | _ -> assert false) in - cata_instr {f_instr; f_literal = (fun _ -> return ())} - -let has_profile ~protocol pr instr = Ok pr = profile ~protocol {instr} + cata_instr { f_instr; f_literal = (fun _ -> return ()) } +;; -let has_arity ~protocol a instr = - has_profile ~protocol (profile_of_arity a) instr - -let arity ~protocol instr = - Result.map arity_of_profile (profile ~protocol instr) +let has_profile ~protocol pr instr = Ok pr = profile ~protocol { instr } +let has_arity ~protocol a instr = has_profile ~protocol (profile_of_arity a) instr +let arity ~protocol instr = Result.map arity_of_profile (profile ~protocol instr) let rec mtype_examples t = match t.mt with - | MT0 Unit -> [MLiteral.unit] - | MT0 Bool -> [MLiteral.bool false; MLiteral.bool true] + | MT0 Unit -> [ MLiteral.unit ] + | MT0 Bool -> [ MLiteral.bool false; MLiteral.bool true ] | MT0 Nat -> - [ - MLiteral.small_int 0 - ; MLiteral.small_int 2 - ; MLiteral.small_int 4 - ; MLiteral.small_int 8 - ] + [ MLiteral.small_int 0 + ; MLiteral.small_int 2 + ; MLiteral.small_int 4 + ; MLiteral.small_int 8 + ] | MT0 Int -> - [ - MLiteral.small_int (-2) - ; MLiteral.small_int 10 - ; MLiteral.small_int 5 - ; MLiteral.small_int 3 - ] + [ MLiteral.small_int (-2) + ; MLiteral.small_int 10 + ; MLiteral.small_int 5 + ; MLiteral.small_int 3 + ] | MT0 Mutez -> - [ - MLiteral.small_int 0 - ; MLiteral.small_int 1000 - ; MLiteral.small_int 2000000 - ; MLiteral.small_int 3000000 - ] + [ MLiteral.small_int 0 + ; MLiteral.small_int 1000 + ; MLiteral.small_int 2000000 + ; MLiteral.small_int 3000000 + ] | MT0 String -> - [ - MLiteral.string "" - ; MLiteral.string "foo" - ; MLiteral.string "bar" - ; MLiteral.string "SmartPy" - ] + [ MLiteral.string "" + ; MLiteral.string "foo" + ; MLiteral.string "bar" + ; MLiteral.string "SmartPy" + ] | MT0 Chain_id | MT0 Bytes | MT0 Bls12_381_g1 @@ -3745,107 +3748,91 @@ let rec mtype_examples t = | MT0 Bls12_381_fr | MT0 Chest_key | MT0 Chest -> - [ - MLiteral.bytes "" - ; MLiteral.bytes (Hex.to_string (`Hex "00")) - ; MLiteral.bytes (Hex.to_string (`Hex "010203")) - ; MLiteral.bytes (Hex.to_string (`Hex "0FFF")) - ] + [ MLiteral.bytes "" + ; MLiteral.bytes (Hex.to_string (`Hex "00")) + ; MLiteral.bytes (Hex.to_string (`Hex "010203")) + ; MLiteral.bytes (Hex.to_string (`Hex "0FFF")) + ] | MT0 Timestamp -> - [ - MLiteral.small_int 0 - ; MLiteral.small_int 1000 - ; MLiteral.small_int 2000000 - ; MLiteral.small_int 3000000 - ] + [ MLiteral.small_int 0 + ; MLiteral.small_int 1000 + ; MLiteral.small_int 2000000 + ; MLiteral.small_int 3000000 + ] | MT0 Address -> - [ - MLiteral.string "tz1..." - ; MLiteral.string "tz2..." - ; MLiteral.string "tz3..." - ; MLiteral.string "KT1..." - ] + [ MLiteral.string "tz1..." + ; MLiteral.string "tz2..." + ; MLiteral.string "tz3..." + ; MLiteral.string "KT1..." + ] | MT0 Key_hash -> - [ - MLiteral.string "tz1..." - ; MLiteral.string "tz2..." - ; MLiteral.string "tz3..." - ] - | MT0 Signature -> [MLiteral.string "edsigt..."; MLiteral.string "edsigu..."] + [ MLiteral.string "tz1..."; MLiteral.string "tz2..."; MLiteral.string "tz3..." ] + | MT0 Signature -> [ MLiteral.string "edsigt..."; MLiteral.string "edsigu..." ] | MT0 Key -> - [ - MLiteral.string "edpkuvNy6TuQ2z8o9wnoaTtTXkzQk7nhegCHfxBc4ecsd4qG71KYNG" - ; MLiteral.string "edpkvThfdv8Efh1MuqSTUk5EnUFCTjqN6kXDCNXpQ8udN3cKRhNDr2" - ] - | MT1 (Option, t) -> - List.map MLiteral.some (mtype_examples t) @ [MLiteral.none] - | MT1 (List, t) -> [MLiteral.seq (mtype_examples t); MLiteral.seq []] - | MT1 (Set, t) -> [MLiteral.seq (mtype_examples t)] + [ MLiteral.string "edpkuvNy6TuQ2z8o9wnoaTtTXkzQk7nhegCHfxBc4ecsd4qG71KYNG" + ; MLiteral.string "edpkvThfdv8Efh1MuqSTUk5EnUFCTjqN6kXDCNXpQ8udN3cKRhNDr2" + ] + | MT1 (Option, t) -> List.map MLiteral.some (mtype_examples t) @ [ MLiteral.none ] + | MT1 (List, t) -> [ MLiteral.seq (mtype_examples t); MLiteral.seq [] ] + | MT1 (Set, t) -> [ MLiteral.seq (mtype_examples t) ] | MT1 (Contract, _t) -> - [ - MLiteral.string "KT1a..." - ; MLiteral.string "KT1b..." - ; MLiteral.string "KT1c..." - ; MLiteral.string "KT1d..." - ] - | MT2 (Pair _, fst, snd) -> ( - let l1 = mtype_examples fst in - let l2 = mtype_examples snd in - match (l1, l2) with - | a1 :: a2 :: _, b1 :: b2 :: _ -> - [ - MLiteral.pair a1 b1 - ; MLiteral.pair a2 b2 - ; MLiteral.pair a1 b2 - ; MLiteral.pair a2 b1 - ] - | _ -> - List.fold_left - (fun acc b -> - List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) - [] l2) - | MT2 (Or _, left, right) -> ( - let l1 = mtype_examples left in - let l2 = mtype_examples right in - match (l1, l2) with - | a1 :: a2 :: _, b1 :: b2 :: _ -> - [ - MLiteral.left a1 - ; MLiteral.left a2 - ; MLiteral.right b1 - ; MLiteral.right b2 - ] - | _ -> - List.fold_left - (fun acc b -> - List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) - [] l2) - | MT2 (Lambda, _, _) -> [MLiteral.seq []] + [ MLiteral.string "KT1a..." + ; MLiteral.string "KT1b..." + ; MLiteral.string "KT1c..." + ; MLiteral.string "KT1d..." + ] + | MT2 (Pair _, fst, snd) -> + let l1 = mtype_examples fst in + let l2 = mtype_examples snd in + (match l1, l2 with + | a1 :: a2 :: _, b1 :: b2 :: _ -> + [ MLiteral.pair a1 b1 + ; MLiteral.pair a2 b2 + ; MLiteral.pair a1 b2 + ; MLiteral.pair a2 b1 + ] + | _ -> + List.fold_left + (fun acc b -> List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) + [] + l2) + | MT2 (Or _, left, right) -> + let l1 = mtype_examples left in + let l2 = mtype_examples right in + (match l1, l2 with + | a1 :: a2 :: _, b1 :: b2 :: _ -> + [ MLiteral.left a1; MLiteral.left a2; MLiteral.right b1; MLiteral.right b2 ] + | _ -> + List.fold_left + (fun acc b -> List.fold_left (fun acc a -> MLiteral.pair a b :: acc) acc l1) + [] + l2) + | MT2 (Lambda, _, _) -> [ MLiteral.seq [] ] | MT2 ((Map | Big_map), k, v) -> - let l1 = mtype_examples k in - let l2 = mtype_examples v in - let rec map2 f acc l1 l2 = - match (l1, l2) with - | a1 :: l1, a2 :: l2 -> map2 f (f a1 a2 :: acc) l1 l2 - | _ -> List.rev acc - in - let l = map2 MLiteral.elt [] l1 l2 in - [MLiteral.seq l] - | MT_var s -> [MLiteral.string (sprintf "no value for %S" s)] - | MT0 Operation -> [MLiteral.string "operation"] - | MT0 (Sapling_state _) -> [MLiteral.seq []] - | MT0 Never -> [MLiteral.string "no value in type never"] - | MT0 (Sapling_transaction _) -> [MLiteral.string "sapling_transaction"] - | MT1 (Ticket, _) -> [MLiteral.string "no example for tickets"] + let l1 = mtype_examples k in + let l2 = mtype_examples v in + let rec map2 f acc l1 l2 = + match l1, l2 with + | a1 :: l1, a2 :: l2 -> map2 f (f a1 a2 :: acc) l1 l2 + | _ -> List.rev acc + in + let l = map2 MLiteral.elt [] l1 l2 in + [ MLiteral.seq l ] + | MT_var s -> [ MLiteral.string (sprintf "no value for %S" s) ] + | MT0 Operation -> [ MLiteral.string "operation" ] + | MT0 (Sapling_state _) -> [ MLiteral.seq [] ] + | MT0 Never -> [ MLiteral.string "no value in type never" ] + | MT0 (Sapling_transaction _) -> [ MLiteral.string "sapling_transaction" ] + | MT1 (Ticket, _) -> [ MLiteral.string "no example for tickets" ] +;; let on_instrs f = - let f_instr instr = f {instr} in - let f_literal literal = {literal} in - cata_literal {f_instr; f_literal} + let f_instr instr = f { instr } in + let f_literal literal = { literal } in + cata_literal { f_instr; f_literal } +;; let display_instr ~protocol t1 instr = - let tinstr = - typecheck_instr ~tparameter:(mt_unit, None) (Stack_ok [t1]) instr - in - display_tinstr ~protocol ~show_stack:false ~new_line:false 0 - (tinstr ~protocol) + let tinstr = typecheck_instr ~tparameter:(mt_unit, None) (Stack_ok [ t1 ]) instr in + display_tinstr ~protocol ~show_stack:false ~new_line:false 0 (tinstr ~protocol) +;;