diff --git a/src/lib_utils/.gitignore b/src/lib_utils/.gitignore new file mode 100644 index 000000000..574db7233 --- /dev/null +++ b/src/lib_utils/.gitignore @@ -0,0 +1,7 @@ +*.install +*.merlin +#* +*_opam +*~ +_build/* +*/_build/* \ No newline at end of file diff --git a/src/lib_utils/cast.ml b/src/lib_utils/cast.ml new file mode 100644 index 000000000..2c02c59b6 --- /dev/null +++ b/src/lib_utils/cast.ml @@ -0,0 +1,190 @@ +module Error_monad = X_error_monad +open Tezos_micheline + +let env = Error_monad.force_lwt ~msg:"Cast:init environment" @@ Init_proto_alpha.init_environment () + +open Memory_proto_alpha +open Alpha_context + +exception Expr_from_string +let expr_of_string str = + let (ast, errs) = Michelson_parser.V1.parse_expression ~check:false str in + (match errs with + | [] -> () + | lst -> ( + Format.printf "expr_from_string: %a\n" Error_monad.pp_print_error lst; + raise Expr_from_string + )); + ast.expanded + +let tl_of_string str = + let (ast, errs) = Michelson_parser.V1.parse_toplevel ~check:false str in + (match errs with + | [] -> () + | lst -> ( + Format.printf "expr_from_string: %a\n" Error_monad.pp_print_error lst; + raise Expr_from_string + )); + ast.expanded + +let lexpr_of_string str = + Script.lazy_expr @@ expr_of_string str + +let ltl_of_string str = + Script.lazy_expr @@ tl_of_string str + +let node_of_string str = + Micheline.root @@ expr_of_string str + +let node_to_string (node:_ Micheline.node) = + let stripped = Micheline.strip_locations node in + let print_node = Micheline_printer.printable Michelson_v1_primitives.string_of_prim stripped in + Micheline_printer.print_expr Format.str_formatter print_node ; + Format.flush_str_formatter () + +open Script_ir_translator + +let rec mapper (Ex_typed_value (ty, a)) = + let open Alpha_environment.Error_monad in + let open Script_typed_ir in + let open Micheline in + match ty, a with + | Big_map_t (kt, vt, Some (`Type_annot "toto")), map -> + let kt = ty_of_comparable_ty kt in + fold_left_s + (fun l (k, v) -> + match v with + | None -> return l + | Some v -> ( + let key = data_to_node (Ex_typed_value (kt, k)) in + let value = data_to_node (Ex_typed_value (vt, v)) in + return (Prim (-1, Michelson_v1_primitives.D_Elt, [ key ; value ], []) :: l)) + ) + [] + (map_fold (fun k v acc -> (k, v) :: acc) map.diff []) >>=? fun items -> + return (Some (Micheline.Seq (-1, String (-1, "...") :: items))) + | _ -> return None + +and data_to_node (Ex_typed_value (ty, data)) = + let tc = env.tezos_context in + let node_lwt = Script_ir_translator.unparse_data tc ~mapper Readable ty data in + let node = fst @@ Error_monad.force_lwt_alpha ~msg:"data to string" node_lwt in + node + +let data_to_string ty data = + let node = data_to_node (Ex_typed_value (ty, data)) in + node_to_string node + +open Script_typed_ir +open Script_interpreter +type ex_typed_stack = + Ex_typed_stack : ('a stack_ty * 'a stack) -> ex_typed_stack + +let stack_to_string stack_ty stack = + let rec aux acc fst (Ex_typed_stack(stack_ty,stack)) = + match (stack_ty, stack) with + | Item_t (hd_ty, tl_ty, _), Item (hd, tl) -> ( + let separator = if not fst then " ; " else "" in + let str = data_to_string hd_ty hd in + let acc = acc ^ separator ^ str in + let new_value = aux acc false (Ex_typed_stack (tl_ty, tl)) in + new_value + ) + | _ -> acc in + aux "" true @@ Ex_typed_stack(stack_ty, stack) + +let ty_to_node ty = + let (node, _) = Error_monad.force_lwt_alpha ~msg:"ty to node" @@ Script_ir_translator.unparse_ty env.tezos_context ty in + node + +type ex_descr = + Ex_descr : (_, _) Script_typed_ir.descr -> ex_descr + +let descr_to_node x = + let open Alpha_context.Script in + let open Micheline in + let open Script_typed_ir in + let rec f : ex_descr -> Script.node = fun descr -> + let prim ?children ?children_nodes p = + match (children, children_nodes) with + | Some children, None -> + Prim (0, p, List.map f children, []) + | Some _, Some _ -> + raise @@ Failure "descr_to_node: too many parameters" + | None, Some children_nodes -> + Prim (0, p, children_nodes, []) + | None, None -> + Prim (0, p, [], []) + in + let (Ex_descr descr) = descr in + match descr.instr with + | Dup -> prim I_DUP + | Drop -> prim I_DROP + | Swap -> prim I_SWAP + | Dip c -> prim ~children:[Ex_descr c] I_DIP + | Car -> prim I_CAR + | Cdr -> prim I_CDR + | Cons_pair -> prim I_PAIR + | Nop -> prim I_NOP + | Seq (a, b) -> Micheline.Seq (0, List.map f [Ex_descr a ; Ex_descr b]) + | Const v -> ( + let (Item_t (ty, _, _)) = descr.aft in + prim ~children_nodes:[data_to_node (Ex_typed_value (ty, v))] I_PUSH + ) + | Failwith _ -> prim I_FAILWITH + | If (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF + | Loop c -> prim ~children:[Ex_descr c] I_LOOP + | If_left (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_LEFT + | Left -> prim I_LEFT + | Right -> prim I_RIGHT + | Loop_left c -> prim ~children:[Ex_descr c] I_LOOP_LEFT + | If_none (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_NONE + | Cons_none _ -> prim I_NONE + | Cons_some -> prim I_SOME + | Nil -> prim I_NIL + | Cons_list -> prim I_CONS + | If_cons (a, b) -> prim ~children:[Ex_descr a ; Ex_descr b] I_IF_CONS + | List_iter _ -> prim I_ITER + | Compare _ -> prim I_COMPARE + | Int_nat -> prim I_INT + | Add_natnat -> prim I_ADD + | Add_natint -> prim I_ADD + | Add_intnat -> prim I_ADD + | Sub_int -> prim I_SUB + | Mul_natnat -> prim I_MUL + | Ediv_natnat -> prim I_MUL + | Map_get -> prim I_GET + | Map_update -> prim I_UPDATE + | Big_map_get -> prim I_GET + | Big_map_update -> prim I_UPDATE + | Gt -> prim I_GT + | Ge -> prim I_GE + | Pack _ -> prim I_PACK + | Unpack _ -> prim I_UNPACK + | Blake2b -> prim I_BLAKE2B + | And -> prim I_AND + | Xor -> prim I_XOR + | _ -> raise @@ Failure "descr to node" in + f @@ Ex_descr x + +let rec flatten_node = + let open Micheline in + function + | Seq (a, lst) -> ( + let aux = function + | Prim (loc, p, children, annot) -> [ Prim (loc, p, List.map flatten_node children, annot) ] + | Seq (_, lst) -> List.map flatten_node lst + | x -> [ x ] in + let seqs = List.map aux @@ List.map flatten_node lst in + Seq (a, List.concat seqs) ) + | x -> x + +let descr_to_string descr = + let node = descr_to_node descr in + let node = flatten_node node in + node_to_string node + +let n_of_int n = + match Script_int.is_nat @@ Script_int.of_int n with + | None -> raise @@ Failure "n_of_int" + | Some n -> n diff --git a/src/lib_utils/dune b/src/lib_utils/dune new file mode 100644 index 000000000..a66a98c30 --- /dev/null +++ b/src/lib_utils/dune @@ -0,0 +1,13 @@ +(library + (name tezos_utils) + (public_name tezos-utils) + (libraries + tezos-stdlib-unix + tezos-crypto + tezos-data-encoding + tezos-protocol-environment + tezos-protocol-alpha + tezos-micheline + michelson-parser + ) +) diff --git a/src/lib_utils/init_proto_alpha.ml b/src/lib_utils/init_proto_alpha.ml new file mode 100644 index 000000000..30a3de657 --- /dev/null +++ b/src/lib_utils/init_proto_alpha.ml @@ -0,0 +1,291 @@ +open Memory_proto_alpha +module Signature = Tezos_base.TzPervasives.Signature +module Data_encoding = Alpha_environment.Data_encoding +module MBytes = Alpha_environment.MBytes +module Error_monad = X_error_monad +open Error_monad + + + +module Context_init = struct + + type account = { + pkh : Signature.Public_key_hash.t ; + pk : Signature.Public_key.t ; + sk : Signature.Secret_key.t ; + } + + let generate_accounts n : (account * Tez_repr.t) list = + let amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in + List.map (fun _ -> + let (pkh, pk, sk) = Signature.generate_key () in + let account = { pkh ; pk ; sk } in + account, amount) + (X_list.range n) + + let make_shell + ~level ~predecessor ~timestamp ~fitness ~operations_hash = + Tezos_base.Block_header.{ + level ; + predecessor ; + timestamp ; + fitness ; + operations_hash ; + (* We don't care of the following values, only the shell validates them. *) + proto_level = 0 ; + validation_passes = 0 ; + context = Alpha_environment.Context_hash.zero ; + } + + let default_proof_of_work_nonce = + MBytes.create Alpha_context.Constants.proof_of_work_nonce_size + + let protocol_param_key = [ "protocol_parameters" ] + + let check_constants_consistency constants = + let open Constants_repr in + let open Error_monad in + let { blocks_per_cycle ; blocks_per_commitment ; + blocks_per_roll_snapshot ; _ } = constants in + Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) + (fun () -> failwith "Inconsistent constants : blocks per commitment must be \ + less than blocks per cycle") >>=? fun () -> + Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) + (fun () -> failwith "Inconsistent constants : blocks per cycle \ + must be superior than blocks per roll snapshot") >>=? + return + + + let initial_context + constants + header + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + = + let open Tezos_base.TzPervasives.Error_monad in + let bootstrap_accounts = + List.map (fun ({ pk ; pkh ; _ }, amount) -> + Parameters_repr.{ public_key_hash = pkh ; public_key = Some pk ; amount } + ) initial_accounts + in + let json = + Data_encoding.Json.construct + Parameters_repr.encoding + Parameters_repr.{ + bootstrap_accounts ; + bootstrap_contracts = [] ; + commitments ; + constants ; + security_deposit_ramp_up_cycles ; + no_reward_cycles ; + } + in + let proto_params = + Data_encoding.Binary.to_bytes_exn Data_encoding.json json + in + Tezos_protocol_environment_memory.Context.( + set empty ["version"] (MBytes.of_string "genesis") + ) >>= fun ctxt -> + Tezos_protocol_environment_memory.Context.( + set ctxt protocol_param_key proto_params + ) >>= fun ctxt -> + Main.init ctxt header + >|= Alpha_environment.wrap_error >>=? fun { context; _ } -> + return context + + let genesis + ?(preserved_cycles = Constants_repr.default.preserved_cycles) + ?(blocks_per_cycle = Constants_repr.default.blocks_per_cycle) + ?(blocks_per_commitment = Constants_repr.default.blocks_per_commitment) + ?(blocks_per_roll_snapshot = Constants_repr.default.blocks_per_roll_snapshot) + ?(blocks_per_voting_period = Constants_repr.default.blocks_per_voting_period) + ?(time_between_blocks = Constants_repr.default.time_between_blocks) + ?(endorsers_per_block = Constants_repr.default.endorsers_per_block) + ?(hard_gas_limit_per_operation = Constants_repr.default.hard_gas_limit_per_operation) + ?(hard_gas_limit_per_block = Constants_repr.default.hard_gas_limit_per_block) + ?(proof_of_work_threshold = Int64.(neg one)) + ?(tokens_per_roll = Constants_repr.default.tokens_per_roll) + ?(michelson_maximum_type_size = Constants_repr.default.michelson_maximum_type_size) + ?(seed_nonce_revelation_tip = Constants_repr.default.seed_nonce_revelation_tip) + ?(origination_size = Constants_repr.default.origination_size) + ?(block_security_deposit = Constants_repr.default.block_security_deposit) + ?(endorsement_security_deposit = Constants_repr.default.endorsement_security_deposit) + ?(block_reward = Constants_repr.default.block_reward) + ?(endorsement_reward = Constants_repr.default.endorsement_reward) + ?(cost_per_byte = Constants_repr.default.cost_per_byte) + ?(hard_storage_limit_per_operation = Constants_repr.default.hard_storage_limit_per_operation) + ?(commitments = []) + ?(security_deposit_ramp_up_cycles = None) + ?(no_reward_cycles = None) + (initial_accounts : (account * Tez_repr.t) list) + = + if initial_accounts = [] then + Pervasives.failwith "Must have one account with a roll to bake"; + + (* Check there is at least one roll *) + let open Tezos_base.TzPervasives.Error_monad in + begin try + let (>>?=) x y = match x with + | Ok(a) -> y a + | Error(b) -> fail @@ List.hd b in + fold_left_s (fun acc (_, amount) -> + Alpha_environment.wrap_error @@ + Tez_repr.(+?) acc amount >>?= fun acc -> + if acc >= tokens_per_roll then + raise Exit + else return acc + ) Tez_repr.zero initial_accounts >>=? fun _ -> + failwith "Insufficient tokens in initial accounts to create one roll" + with Exit -> return () + end >>=? fun () -> + + let constants : Constants_repr.parametric = { + preserved_cycles ; + blocks_per_cycle ; + blocks_per_commitment ; + blocks_per_roll_snapshot ; + blocks_per_voting_period ; + time_between_blocks ; + endorsers_per_block ; + hard_gas_limit_per_operation ; + hard_gas_limit_per_block ; + proof_of_work_threshold ; + tokens_per_roll ; + michelson_maximum_type_size ; + seed_nonce_revelation_tip ; + origination_size ; + block_security_deposit ; + endorsement_security_deposit ; + block_reward ; + endorsement_reward ; + cost_per_byte ; + hard_storage_limit_per_operation ; + } in + check_constants_consistency constants >>=? fun () -> + + let hash = + Alpha_environment.Block_hash.of_b58check_exn "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" + in + let shell = make_shell + ~level:0l + ~predecessor:hash + ~timestamp:Tezos_base.TzPervasives.Time.epoch + ~fitness: (Fitness_repr.from_int64 0L) + ~operations_hash: Alpha_environment.Operation_list_list_hash.zero in + initial_context + constants + shell + commitments + initial_accounts + security_deposit_ramp_up_cycles + no_reward_cycles + >>=? fun context -> + return (context, shell, hash) + + let init + ?(slow=false) + ?preserved_cycles + ?endorsers_per_block + ?commitments + n = + let open Error_monad in + let accounts = generate_accounts n in + let contracts = List.map (fun (a, _) -> + Alpha_context.Contract.implicit_contract (a.pkh)) accounts in + begin + if slow then + genesis + ?preserved_cycles + ?endorsers_per_block + ?commitments + accounts + else + genesis + ?preserved_cycles + ~blocks_per_cycle:32l + ~blocks_per_commitment:4l + ~blocks_per_roll_snapshot:8l + ~blocks_per_voting_period:(Int32.mul 32l 8l) + ?endorsers_per_block + ?commitments + accounts + end >>=? fun ctxt -> + return (ctxt, accounts, contracts) + + let contents + ?(proof_of_work_nonce = default_proof_of_work_nonce) + ?(priority = 0) ?seed_nonce_hash () = + Alpha_context.Block_header.({ + priority ; + proof_of_work_nonce ; + seed_nonce_hash ; + }) + + + let begin_construction ?(priority=0) ~timestamp ~(header:Alpha_context.Block_header.shell_header) ~hash ctxt = + let contents = contents ~priority () in + let protocol_data = Alpha_context.Block_header.{ + contents ; + signature = Signature.zero ; + } in + let timestamp = Alpha_environment.Time.add timestamp @@ Int64.of_int 180 in + Main.begin_construction + ~chain_id: Alpha_environment.Chain_id.zero + ~predecessor_context: ctxt + ~predecessor_timestamp: header.timestamp + ~predecessor_fitness: header.fitness + ~predecessor_level: header.level + ~predecessor:hash + ~timestamp + ~protocol_data + () >>= fun x -> Lwt.return @@ Alpha_environment.wrap_error x >>=? fun state -> + return state.ctxt + + let main n = + init n >>=? fun ((ctxt, header, hash), accounts, contracts) -> + let timestamp = Tezos_base.Time.now () in + begin_construction ~timestamp ~header ~hash ctxt >>=? fun ctxt -> + return (ctxt, accounts, contracts) + +end + +type identity = { + public_key_hash : Signature.public_key_hash; + public_key : Signature.public_key; + secret_key : Signature.secret_key; + implicit_contract : Alpha_context.Contract.t; + } + +type environment = { + tezos_context : Alpha_context.t ; + identities : identity list ; + } + +let init_environment () = + Context_init.main 10 >>=? fun (tezos_context, accounts, contracts) -> + let accounts = List.map fst accounts in + let tezos_context = Alpha_context.Gas.set_limit tezos_context @@ Z.of_int 350000 in + let identities = + List.map (fun ((a:Context_init.account), c) -> { + public_key = a.pk ; + public_key_hash = a.pkh ; + secret_key = a.sk ; + implicit_contract = c ; + }) @@ + List.combine accounts contracts in + return {tezos_context ; identities} + +let contextualize ~msg ?environment f = + let lwt = + let environment = match environment with + | None -> init_environment () + | Some x -> return x in + environment >>=? f + in + force_ok ~msg @@ Lwt_main.run lwt + +let dummy_environment = + X_error_monad.force_lwt ~msg:"Init_proto_alpha : initing dummy environment" @@ + init_environment () diff --git a/src/lib_utils/michelson-parser/dune b/src/lib_utils/michelson-parser/dune new file mode 100644 index 000000000..10b030335 --- /dev/null +++ b/src/lib_utils/michelson-parser/dune @@ -0,0 +1,15 @@ +(library + (name michelson_parser) + (public_name michelson-parser) + (libraries + tezos-base + tezos-memory-proto-alpha + ) + (flags (:standard -w -9-32 -safe-string + -open Tezos_base__TzPervasives + ))) + +(alias + (name runtest_indent) + (deps (glob_files *.ml*)) + (action (run bash %{libexec:tezos-stdlib:test-ocp-indent.sh} %{deps}))) diff --git a/src/lib_utils/michelson-parser/michelson-parser.opam b/src/lib_utils/michelson-parser/michelson-parser.opam new file mode 100644 index 000000000..cbf890d09 --- /dev/null +++ b/src/lib_utils/michelson-parser/michelson-parser.opam @@ -0,0 +1,21 @@ +name: "michelson-parser" +opam-version: "2.0" +version: "1.0" +maintainer: "gabriel.alfour@gmail.com" +authors: [ "Galfour" ] +homepage: "https://gitlab.com/gabriel.alfour/tezos" +bug-reports: "https://gitlab.com/gabriel.alfour/tezos/issues" +dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos.git" +license: "MIT" +depends: [ + "ocamlfind" { build } + "dune" + "tezos-memory-proto-alpha" +] +build: [ + [ "dune" "build" "-p" name "-j" jobs ] + [ "mv" "src/lib_utils/michelson-parser/michelson-parser.install" "." ] +] +url { + src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" +} diff --git a/src/lib_utils/michelson-parser/michelson_v1_macros.ml b/src/lib_utils/michelson-parser/michelson_v1_macros.ml new file mode 100644 index 000000000..1fc947f5b --- /dev/null +++ b/src/lib_utils/michelson-parser/michelson_v1_macros.ml @@ -0,0 +1,1176 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Tezos_micheline +open Micheline + +module IntMap = Map.Make (Compare.Int) + +type 'l node = ('l, string) Micheline.node + +type error += Unexpected_macro_annotation of string +type error += Sequence_expected of string +type error += Invalid_arity of string * int * int + +let rec check_letters str i j f = + i > j || f (String.get str i) && check_letters str (i + 1) j f + +let expand_caddadr original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'C' + && String.get str (len - 1) = 'R' + && check_letters str 1 (len - 2) + (function 'A' | 'D' -> true | _ -> false) then + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) + end >>? fun () -> + let rec parse i annot acc = + if i = 0 then + Seq (loc, acc) + else + let annot = if i = len - 2 then annot else [] in + match String.get str i with + | 'A' -> parse (i - 1) [] (Prim (loc, "CAR", [], annot) :: acc) + | 'D' -> parse (i - 1) [] (Prim (loc, "CDR", [], annot) :: acc) + | _ -> assert false in + ok (Some (parse (len - 2) annot [])) + else + ok None + | _ -> ok None + +let extract_first_annot annot char = + let rec extract_first_annot others = function + | [] -> None, List.rev others + | a :: rest -> + try + if a.[0] = char + then Some a, List.rev_append others rest + else extract_first_annot (a :: others) rest + with Invalid_argument _ -> extract_first_annot (a :: others) rest + in + extract_first_annot [] annot + +let extract_first_field_annot annot = extract_first_annot annot '%' +let extract_first_var_annot annot = extract_first_annot annot '@' + +let extract_field_annots annot = + List.partition (fun a -> + match a.[0] with + | '%' -> true + | _ -> false + | exception Invalid_argument _ -> false + ) annot + +let expand_set_caddadr original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len >= 7 + && String.sub str 0 5 = "SET_C" + && String.get str (len - 1) = 'R' + && check_letters str 5 (len - 2) + (function 'A' | 'D' -> true | _ -> false) then + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) + end >>? fun () -> + begin match extract_field_annots annot with + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str) + end >>? fun (field_annot, annot) -> + let rec parse i acc = + if i = 4 then + acc + else + let annot = if i = 5 then annot else [] in + match String.get str i with + | 'A' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CAR", [], [ "@%%" ]) ; + acc ]) ], []) ; + Prim (loc, "CDR", [], [ "@%%" ]) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + parse (i - 1) acc + | 'D' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CDR", [], [ "@%%" ]) ; + acc ]) ], []) ; + Prim (loc, "CAR", [], [ "@%%" ]) ; + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + parse (i - 1) acc + | _ -> assert false in + match String.get str (len - 2) with + | 'A' -> + let access_check = match field_annot with + | None -> [] + | Some f -> [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CAR", [], [ f ]) ; + Prim (loc, "DROP", [], []) ; + ] in + let encoding = [ Prim (loc, "CDR", [], [ "@%%" ]) ; + Prim (loc, "SWAP", [], []) ] in + let pair = [ Prim (loc, "PAIR", [], + [ Option.unopt field_annot ~default:"%" ; "%@" ]) ] in + let init = Seq (loc, access_check @ encoding @ pair) in + ok (Some (parse (len - 3) init)) + | 'D' -> + let access_check = match field_annot with + | None -> [] + | Some f -> [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CDR", [], [ f ]) ; + Prim (loc, "DROP", [], []) ; + ] in + let encoding = [ Prim (loc, "CAR", [], [ "@%%" ]) ] in + let pair = [ Prim (loc, "PAIR", [], + [ "%@" ; Option.unopt field_annot ~default:"%" ]) ] in + let init = Seq (loc, access_check @ encoding @ pair) in + ok (Some (parse (len - 3) init)) + | _ -> assert false + else + ok None + | _ -> ok None + +let expand_map_caddadr original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len >= 7 + && String.sub str 0 5 = "MAP_C" + && String.get str (len - 1) = 'R' + && check_letters str 5 (len - 2) + (function 'A' | 'D' -> true | _ -> false) then + begin match args with + | [ Seq _ as code ] -> ok code + | [ _ ] -> error (Sequence_expected str) + | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) + end >>? fun code -> + begin match extract_field_annots annot with + | [], annot -> ok (None, annot) + | [f], annot -> ok (Some f, annot) + | _, _ -> error (Unexpected_macro_annotation str) + end >>? fun (field_annot, annot) -> + let rec parse i acc = + if i = 4 then + acc + else + let annot = if i = 5 then annot else [] in + match String.get str i with + | 'A' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CAR", [], [ "@%%" ]) ; + acc ]) ], []) ; + Prim (loc, "CDR", [], [ "@%%" ]) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + parse (i - 1) acc + | 'D' -> + let acc = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "DIP", + [ Seq (loc, + [ Prim (loc, "CDR", [], [ "@%%" ]) ; + acc ]) ], []) ; + Prim (loc, "CAR", [], [ "@%%" ]) ; + Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ]) in + parse (i - 1) acc + | _ -> assert false in + let cr_annot = match field_annot with + | None -> [] + | Some f -> [ "@" ^ String.sub f 1 (String.length f - 1) ] in + match String.get str (len - 2) with + | 'A' -> + let init = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CDR", [], [ "@%%" ]) ; + Prim (loc, "DIP", + [ Seq (loc, [ Prim (loc, "CAR", [], cr_annot) ; code ]) ], []) ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "PAIR", [], + [ Option.unopt field_annot ~default:"%" ; "%@"]) ]) in + ok (Some (parse (len - 3) init)) + | 'D' -> + let init = + Seq (loc, + [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CDR", [], cr_annot) ; + code ; + Prim (loc, "SWAP", [], []) ; + Prim (loc, "CAR", [], [ "@%%" ]) ; + Prim (loc, "PAIR", [], + [ "%@" ; Option.unopt field_annot ~default:"%" ]) ]) in + ok (Some (parse (len - 3) init)) + | _ -> assert false + else + ok None + | _ -> ok None + +exception Not_a_roman + +let decimal_of_roman roman = + (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *) + let arabic = ref 0 in + let lastval = ref 0 in + for i = (String.length roman) - 1 downto 0 do + let n = + match roman.[i] with + | 'M' -> 1000 + | 'D' -> 500 + | 'C' -> 100 + | 'L' -> 50 + | 'X' -> 10 + | 'V' -> 5 + | 'I' -> 1 + | _ -> raise_notrace Not_a_roman + in + if Compare.Int.(n < !lastval) + then arabic := !arabic - n + else arabic := !arabic + n; + lastval := n + done; + !arabic + +let expand_dxiiivp original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'D' + && String.get str (len - 1) = 'P' then + try + let depth = decimal_of_roman (String.sub str 1 (len - 2)) in + let rec make i acc = + if i = 0 then + acc + else + make (i - 1) + (Seq (loc, [ Prim (loc, "DIP", [ acc ], annot) ])) in + match args with + | [ Seq (_, _) as arg ] -> ok @@ Some (make depth arg) + | [ _ ] -> error (Sequence_expected str) + | [] | _ :: _ :: _ -> error (Invalid_arity (str, List.length args, 1)) + with Not_a_roman -> ok None + else ok None + | _ -> ok None + +exception Not_a_pair + +let rec dip ~loc depth instr = + if depth <= 0 + then instr + else dip ~loc (depth - 1) (Prim (loc, "DIP", [ Seq (loc, [ instr ]) ], [])) + +type pair_item = + | A + | I + | P of int * pair_item * pair_item + +let parse_pair_substr str ~len start = + let rec parse ?left i = + if i = len - 1 then + raise_notrace Not_a_pair + else if String.get str i = 'P' then + let next_i, l = parse ~left:true (i + 1) in + let next_i, r = parse ~left:false next_i in + next_i, P (i, l, r) + else if String.get str i = 'A' && left = Some true then + i + 1, A + else if String.get str i = 'I' && left <> Some true then + i + 1, I + else + raise_notrace Not_a_pair in + let last, ast = parse start in + if last <> len - 1 then + raise_notrace Not_a_pair + else + ast + +let unparse_pair_item ast = + let rec unparse ast acc = match ast with + | P (_, l, r) -> unparse r (unparse l ("P" :: acc)) + | A -> "A" :: acc + | I -> "I" :: acc in + List.rev ("R" :: unparse ast []) |> String.concat "" + +let pappaiir_annots_pos ast annot = + let rec find_annots_pos p_pos ast annots acc = + match ast, annots with + | _, [] -> annots, acc + | P (i, left, right), _ -> + let annots, acc = find_annots_pos i left annots acc in + find_annots_pos i right annots acc + | A, a :: annots -> + let pos = match IntMap.find_opt p_pos acc with + | None -> [ a ], [] + | Some (_, cdr) -> [ a ], cdr in + annots, IntMap.add p_pos pos acc + | I, a :: annots -> + let pos = match IntMap.find_opt p_pos acc with + | None -> [], [ a ] + | Some (car, _) -> car, [ a ] in + annots, IntMap.add p_pos pos acc in + snd (find_annots_pos 0 ast annot IntMap.empty) + +let expand_pappaiir original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len > 4 + && String.get str 0 = 'P' + && String.get str (len - 1) = 'R' + && check_letters str 1 (len - 2) + (function 'P' | 'A' | 'I' -> true | _ -> false) then + try + let field_annots, annot = extract_field_annots annot in + let ast = parse_pair_substr str ~len 0 in + let field_annots_pos = pappaiir_annots_pos ast field_annots in + let rec parse p (depth, acc) = + match p with + | P (i, left, right) -> + let annot = + match i, IntMap.find_opt i field_annots_pos with + | 0, None -> annot + | _, None -> [] + | 0, Some ([], cdr_annot) -> "%" :: cdr_annot @ annot + | _, Some ([], cdr_annot) -> "%" :: cdr_annot + | 0, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot @ annot + | _, Some (car_annot, cdr_annot) -> car_annot @ cdr_annot + in + let acc = dip ~loc depth (Prim (loc, "PAIR", [], annot)) :: acc in + (depth, acc) + |> parse left + |> parse right + | A | I -> (depth + 1, acc) + in + let _, expanded = parse ast (0, []) in + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) + end >>? fun () -> + ok (Some (Seq (loc, expanded))) + with Not_a_pair -> ok None + else + ok None + | _ -> ok None + +let expand_unpappaiir original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len >= 6 + && String.sub str 0 3 = "UNP" + && String.get str (len - 1) = 'R' + && check_letters str 3 (len - 2) + (function 'P' | 'A' | 'I' -> true | _ -> false) then + try + let unpair car_annot cdr_annot = + Seq (loc, [ Prim (loc, "DUP", [], []) ; + Prim (loc, "CAR", [], car_annot) ; + dip ~loc 1 (Prim (loc, "CDR", [], cdr_annot)) ; + ]) in + let ast = parse_pair_substr str ~len 2 in + let annots_pos = pappaiir_annots_pos ast annot in + let rec parse p (depth, acc) = + match p with + | P (i, left, right) -> + let car_annot, cdr_annot = + match IntMap.find_opt i annots_pos with + | None -> [], [] + | Some (car_annot, cdr_annot) -> car_annot, cdr_annot in + let acc = dip ~loc depth (unpair car_annot cdr_annot) :: acc in + (depth, acc) + |> parse left + |> parse right + | A | I -> (depth + 1, acc) in + let _, rev_expanded = parse ast (0, []) in + let expanded = Seq (loc, List.rev rev_expanded) in + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) + end >>? fun () -> + ok (Some expanded) + with Not_a_pair -> ok None + else + ok None + | _ -> ok None + +exception Not_a_dup + +let expand_duuuuup original = + match original with + | Prim (loc, str, args, annot) -> + let len = String.length str in + if len > 3 + && String.get str 0 = 'D' + && String.get str (len - 1) = 'P' + && check_letters str 1 (len - 2) ((=) 'U') then + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (str, List.length args, 0)) + end >>? fun () -> + try + let rec parse i acc = + if i = 1 then acc + else if String.get str i = 'U' then + parse (i - 1) + (Seq (loc, [ Prim (loc, "DIP", [ acc ], []) ; + Prim (loc, "SWAP", [], []) ])) + else + raise_notrace Not_a_dup in + ok (Some (parse (len - 2) (Seq (loc, [ Prim (loc, "DUP", [], annot) ])))) + with Not_a_dup -> ok None + else + ok None + | _ -> ok None + +let expand_compare original = + let cmp loc is annot = + let is = + match List.rev_map (fun i -> Prim (loc, i, [], [])) is with + | Prim (loc, i, args, _) :: r -> List.rev (Prim (loc, i, args, annot) :: r) + | is -> List.rev is + in + ok (Some (Seq (loc, is))) in + let ifcmp loc is l r annot = + let is = + List.map (fun i -> Prim (loc, i, [], [])) is @ + [ Prim (loc, "IF", [ l ; r ], annot) ] in + ok (Some (Seq (loc, is))) in + match original with + | Prim (loc, "CMPEQ", [], annot) -> + cmp loc [ "COMPARE" ; "EQ" ] annot + | Prim (loc, "CMPNEQ", [], annot) -> + cmp loc [ "COMPARE" ; "NEQ" ] annot + | Prim (loc, "CMPLT", [], annot) -> + cmp loc [ "COMPARE" ; "LT" ] annot + | Prim (loc, "CMPGT", [], annot) -> + cmp loc [ "COMPARE" ; "GT" ] annot + | Prim (loc, "CMPLE", [], annot) -> + cmp loc [ "COMPARE" ; "LE" ] annot + | Prim (loc, "CMPGE", [], annot) -> + cmp loc [ "COMPARE" ; "GE" ] annot + | Prim (_, ("CMPEQ" | "CMPNEQ" | "CMPLT" + | "CMPGT" | "CMPLE" | "CMPGE" as str), args, []) -> + error (Invalid_arity (str, List.length args, 0)) + | Prim (loc, "IFCMPEQ", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "EQ" ] l r annot + | Prim (loc, "IFCMPNEQ", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "NEQ" ] l r annot + | Prim (loc, "IFCMPLT", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "LT" ] l r annot + | Prim (loc, "IFCMPGT", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "GT" ] l r annot + | Prim (loc, "IFCMPLE", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "LE" ] l r annot + | Prim (loc, "IFCMPGE", [ l ; r ], annot) -> + ifcmp loc [ "COMPARE" ; "GE" ] l r annot + | Prim (loc, "IFEQ", [ l ; r ], annot) -> + ifcmp loc [ "EQ" ] l r annot + | Prim (loc, "IFNEQ", [ l ; r ], annot) -> + ifcmp loc [ "NEQ" ] l r annot + | Prim (loc, "IFLT", [ l ; r ], annot) -> + ifcmp loc [ "LT" ] l r annot + | Prim (loc, "IFGT", [ l ; r ], annot) -> + ifcmp loc [ "GT" ] l r annot + | Prim (loc, "IFLE", [ l ; r ], annot) -> + ifcmp loc [ "LE" ] l r annot + | Prim (loc, "IFGE", [ l ; r ], annot) -> + ifcmp loc [ "GE" ] l r annot + | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" + | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" + | "IFEQ" | "IFNEQ" | "IFLT" + | "IFGT" | "IFLE" | "IFGE" as str), args, []) -> + error (Invalid_arity (str, List.length args, 2)) + | Prim (_, ("IFCMPEQ" | "IFCMPNEQ" | "IFCMPLT" + | "IFCMPGT" | "IFCMPLE" | "IFCMPGE" + | "IFEQ" | "IFNEQ" | "IFLT" + | "IFGT" | "IFLE" | "IFGE" as str), [], _ :: _) -> + error (Unexpected_macro_annotation str) + | _ -> ok None + +let expand_asserts original = + let may_rename loc = function + | [] -> Seq (loc, []) + | annot -> Seq (loc, [ Prim (loc, "RENAME", [], annot) ]) + in + let fail_false ?(annot=[]) loc = + [may_rename loc annot; Seq (loc, [ Prim (loc, "FAIL", [], []) ])] + in + let fail_true ?(annot=[]) loc = + [Seq (loc, [ Prim (loc, "FAIL", [], []) ]); may_rename loc annot] + in + match original with + | Prim (loc, "ASSERT", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF", fail_false loc, []) ])) + | Prim (loc, "ASSERT_NONE", [], []) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_false loc, []) ])) + | Prim (loc, "ASSERT_SOME", [], annot) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", fail_true ~annot loc, []) ])) + | Prim (loc, "ASSERT_LEFT", [], annot) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_false ~annot loc, []) ])) + | Prim (loc, "ASSERT_RIGHT", [], annot) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", fail_true ~annot loc, []) ])) + | Prim (_, ("ASSERT" | "ASSERT_NONE" | "ASSERT_SOME" + | "ASSERT_LEFT" | "ASSERT_RIGHT" as str), args, []) -> + error (Invalid_arity (str, List.length args, 0)) + | Prim (_, ( "ASSERT" | "ASSERT_NONE" as str), [], _ :: _) -> + error (Unexpected_macro_annotation str) + | Prim (loc, s, args, annot) + when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> + begin match args with + | [] -> ok () + | _ :: _ -> error (Invalid_arity (s, List.length args, 0)) + end >>? fun () -> + begin match annot with + | _ :: _ -> (error (Unexpected_macro_annotation s)) + | [] -> ok () + end >>? fun () -> + begin + let remaining = String.(sub s 7 (length s - 7)) in + let remaining_prim = Prim (loc, remaining, [], []) in + match remaining with + | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" -> + ok @@ Some (Seq (loc, [ remaining_prim ; + Prim (loc, "IF", fail_false loc, []) ])) + | _ -> + begin + expand_compare remaining_prim >|? function + | None -> None + | Some seq -> + Some (Seq (loc, [ seq ; + Prim (loc, "IF", fail_false loc, []) ])) + end + end + | _ -> ok None + + +let expand_if_some = function + | Prim (loc, "IF_SOME", [ right ; left ], annot) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_NONE", [ left ; right ], annot) ])) + | Prim (_, "IF_SOME", args, _annot) -> + error (Invalid_arity ("IF_SOME", List.length args, 2)) + | _ -> ok @@ None + +let expand_if_right = function + | Prim (loc, "IF_RIGHT", [ right ; left ], annot) -> + ok @@ Some (Seq (loc, [ Prim (loc, "IF_LEFT", [ left ; right ], annot) ])) + | Prim (_, "IF_RIGHT", args, _annot) -> + error (Invalid_arity ("IF_RIGHT", List.length args, 2)) + | _ -> ok @@ None + +let expand_fail = function + | Prim (loc, "FAIL", [], []) -> + ok @@ Some (Seq (loc, [ + Prim (loc, "UNIT", [], []) ; + Prim (loc, "FAILWITH", [], []) ; + ])) + | _ -> ok @@ None + +let expand original = + let rec try_expansions = function + | [] -> ok @@ original + | expander :: expanders -> + expander original >>? function + | None -> try_expansions expanders + | Some rewritten -> ok rewritten in + try_expansions + [ expand_caddadr ; + expand_set_caddadr ; + expand_map_caddadr ; + expand_dxiiivp ; + (* expand_paaiair ; *) + expand_pappaiir ; + (* expand_unpaaiair ; *) + expand_unpappaiir ; + expand_duuuuup ; + expand_compare ; + expand_asserts ; + expand_if_some ; + expand_if_right ; + expand_fail ; + ] + +let expand_rec expr = + let rec error_map (expanded, errors) f = function + | [] -> (List.rev expanded, List.rev errors) + | hd :: tl -> + let (new_expanded, new_errors) = f hd in + error_map + (new_expanded :: expanded, List.rev_append new_errors errors) + f tl in + let error_map = error_map ([], []) in + let rec expand_rec expr = + match expand expr with + | Ok expanded -> + begin + match expanded with + | Seq (loc, items) -> + let items, errors = error_map expand_rec items in + (Seq (loc, items), errors) + | Prim (loc, name, args, annot) -> + let args, errors = error_map expand_rec args in + (Prim (loc, name, args, annot), errors) + | Int _ | String _ | Bytes _ as atom -> (atom, []) end + | Error errors -> (expr, errors) in + expand_rec expr + +let unexpand_caddadr expanded = + let rec rsteps acc = function + | [] -> Some acc + | Prim (_, "CAR" , [], []) :: rest -> + rsteps ("A" :: acc) rest + | Prim (_, "CDR" , [], []) :: rest -> + rsteps ("D" :: acc) rest + | _ -> None in + match expanded with + | Seq (loc, (Prim (_, "CAR" , [], []) :: _ as nodes)) + | Seq (loc, (Prim (_, "CDR" , [], []) :: _ as nodes)) -> + begin match rsteps [] nodes with + | Some steps -> + let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [], [])) + | None -> None + end + | _ -> None + +let unexpand_set_caddadr expanded = + let rec steps acc annots = function + | Seq (loc, + [ Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], _) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "A" :: acc, annots) + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CAR", [], [ field_annot ]) ; + Prim (_, "DROP", [], []) ; + Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "A" :: acc, field_annot :: annots) + | Seq (loc, + [ Prim (_, "CAR", [], _) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "D" :: acc, annots) + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], [ field_annot ]) ; + Prim (_, "DROP", [], []) ; + Prim (_, "CAR", [], _) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "D" :: acc, field_annot :: annots) + | Seq (_, + [ Prim (_, "DUP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], _) ; + sub ]) ], []) ; + Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], pair_annots) ]) -> + let _, pair_annots = extract_field_annots pair_annots in + steps ("A" :: acc) (List.rev_append pair_annots annots) sub + | Seq (_, + [ Prim (_, "DUP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], _) ; + sub ]) ], []) ; + Prim (_, "CAR", [], _) ; + Prim (_, "PAIR", [], pair_annots) ]) -> + let _, pair_annots = extract_field_annots pair_annots in + steps ("D" :: acc) (List.rev_append pair_annots annots) sub + | _ -> None in + match steps [] [] expanded with + | Some (loc, steps, annots) -> + let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [], List.rev annots)) + | None -> None + +let unexpand_map_caddadr expanded = + let rec steps acc annots = function + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], []) ; + code ]) ], []) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "A" :: acc, annots, code) + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], [ field_annot ]) ; + code ]) ], []) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "A" :: acc, field_annot :: annots, code) + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], []) ; + code ; + Prim (_, "SWAP", [], []) ; + Prim (_, "CAR", [], _) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "D" :: acc, annots, code) + | Seq (loc, + [ Prim (_, "DUP", [], []) ; + Prim (_, "CDR", [], [ field_annot ]) ; + code ; + Prim (_, "SWAP", [], []) ; + Prim (_, "CAR", [], _) ; + Prim (_, "PAIR", [], _) ]) -> + Some (loc, "D" :: acc, field_annot :: annots, code) + | Seq (_, + [ Prim (_, "DUP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CAR", [], _) ; + sub ]) ], []) ; + Prim (_, "CDR", [], _) ; + Prim (_, "SWAP", [], []) ; + Prim (_, "PAIR", [], pair_annots) ]) -> + let _, pair_annots = extract_field_annots pair_annots in + steps ("A" :: acc) (List.rev_append pair_annots annots) sub + | Seq (_, + [ Prim (_, "DUP", [], []) ; + Prim (_, "DIP", + [ Seq (_, + [ Prim (_, "CDR", [], []) ; + sub ]) ], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "PAIR", [], pair_annots) ]) -> + let _, pair_annots = extract_field_annots pair_annots in + steps ("D" :: acc) (List.rev_append pair_annots annots) sub + | _ -> None in + match steps [] [] expanded with + | Some (loc, steps, annots, code) -> + let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in + Some (Prim (loc, name, [ code ], List.rev annots)) + | None -> None + +let roman_of_decimal decimal = + (* http://rosettacode.org/wiki/Roman_numerals/Encode#OCaml *) + let digit x y z = function + | 1 -> [ x ] + | 2 -> [ x ; x ] + | 3 -> [ x ; x ; x ] + | 4 -> [ x ; y ] + | 5 -> [ y ] + | 6 -> [ y ; x ] + | 7 -> [ y ; x ; x ] + | 8 -> [ y ; x ; x ; x ] + | 9 -> [ x ; z ] + | _ -> assert false in + let rec to_roman x = + if x = 0 then [] + else if x < 0 then + invalid_arg "Negative roman numeral" + else if x >= 1000 then + "M" :: to_roman (x - 1000) + else if x >= 100 then + digit "C" "D" "M" (x / 100) @ to_roman (x mod 100) + else if x >= 10 then + digit "X" "L" "C" (x / 10) @ to_roman (x mod 10) + else + digit "I" "V" "X" x in + String.concat "" (to_roman decimal) + +let dxiiivp_roman_of_decimal decimal = + let roman = roman_of_decimal decimal in + if String.length roman = 1 then + (* too short for D*P, fall back to IIIII... *) + String.concat "" (List.init decimal (fun _ -> "I")) + else + roman + +let unexpand_dxiiivp expanded = + match expanded with + | Seq (loc, + [ Prim (_, "DIP", + [ Seq (_, [ Prim (_, "DIP", [ _ ], []) ]) as sub ], + []) ]) -> + let rec count acc = function + | Seq (_, [ Prim (_, "DIP", [ sub ], []) ]) -> count (acc + 1) sub + | sub -> (acc, sub) in + let depth, sub = count 1 sub in + let name = "D" ^ dxiiivp_roman_of_decimal depth ^ "P" in + Some (Prim (loc, name, [ sub ], [])) + | _ -> None + +let unexpand_duuuuup expanded = + let rec help expanded = + match expanded with + | Seq (loc, [ Prim (_, "DUP", [], []) ]) -> Some (loc, 1) + | Seq (_, [ Prim (_, "DIP", [expanded'], []); + Prim (_, "SWAP", [], []) ]) -> + begin + match help expanded' with + | None -> None + | Some (loc, n) -> Some (loc, n + 1) + end + | _ -> None + in let rec dupn = function + | 0 -> "P" + | n -> "U" ^ (dupn (n - 1)) in + match help expanded with + | None -> None + | Some (loc, n) -> Some (Prim (loc, "D" ^ (dupn n), [], [])) + +let rec normalize_pair_item ?(right=false) = function + | P (i, a, b) -> P (i, normalize_pair_item a, normalize_pair_item ~right:true b) + | A when right -> I + | A -> A + | I -> I + +let unexpand_pappaiir expanded = + match expanded with + | Seq (_, [ Prim (_, "PAIR", [], []) ]) -> Some expanded + | Seq (loc, (_ :: _ as nodes)) -> + let rec exec stack nodes = match nodes, stack with + | [], _ -> stack + | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> + exec (a :: exec rstack sub) rest + | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> + exec (A :: exec [] sub) rest + | Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack -> + exec (P (0, a, b) :: rstack) rest + | Prim (_, "PAIR", [], []) :: rest, [ a ] -> + exec [ P (0, a, I) ] rest + | Prim (_, "PAIR", [], []) :: rest, [] -> + exec [ P (0, A, I) ] rest + | _ -> raise_notrace Not_a_pair in + begin match exec [] nodes with + | [] -> None + | res :: _ -> + let res = normalize_pair_item res in + let name = unparse_pair_item res in + Some (Prim (loc, name, [], [])) + | exception Not_a_pair -> None + end + | _ -> None + +let unexpand_unpappaiir expanded = + match expanded with + | Seq (loc, (_ :: _ as nodes)) -> + let rec exec stack nodes = match nodes, stack with + | [], _ -> stack + | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, a :: rstack -> + exec (a :: exec rstack sub) rest + | Prim (_, "DIP", [ Seq (_, sub) ], []) :: rest, [] -> + exec (A :: exec [] sub) rest + | Seq (_, [ Prim (_, "DUP", [], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "DIP", + [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], + []) ]) :: rest, + a :: b :: rstack -> + exec (P (0, a, b) :: rstack) rest + | Seq (_, [ Prim (_, "DUP", [], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "DIP", + [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], + []) ]) :: rest, + [ a ] -> + exec [ P (0, a, I) ] rest + | Seq (_, [ Prim (_, "DUP", [], []) ; + Prim (_, "CAR", [], []) ; + Prim (_, "DIP", + [ Seq (_, [ Prim (_, "CDR", [], []) ]) ], + []) ]) :: rest, + [] -> + exec [ P (0, A, I) ] rest + | _ -> raise_notrace Not_a_pair in + begin match exec [] (List.rev nodes) with + | [] -> None + | res :: _ -> + let res = normalize_pair_item res in + let name = "UN" ^ unparse_pair_item res in + Some (Prim (loc, name, [], [])) + | exception Not_a_pair -> None + end + | _ -> None + + +let unexpand_compare expanded = + match expanded with + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "EQ", [], annot) ]) -> + Some (Prim (loc, "CMPEQ", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "NEQ", [], annot) ]) -> + Some (Prim (loc, "CMPNEQ", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "LT", [], annot) ]) -> + Some (Prim (loc, "CMPLT", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "GT", [], annot) ]) -> + Some (Prim (loc, "CMPGT", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "LE", [], annot) ]) -> + Some (Prim (loc, "CMPLE", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "GE", [], annot) ]) -> + Some (Prim (loc, "CMPGE", [], annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "EQ", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPEQ", args, annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "NEQ", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPNEQ", args, annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "LT", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPLT", args, annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "GT", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPGT", args, annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "LE", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPLE", args, annot)) + | Seq (loc, [ Prim (_, "COMPARE", [], _) ; + Prim (_, "GE", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFCMPGE", args, annot)) + | Seq (loc, [ Prim (_, "EQ", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFEQ", args, annot)) + | Seq (loc, [ Prim (_, "NEQ", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFNEQ", args, annot)) + | Seq (loc, [ Prim (_, "LT", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFLT", args, annot)) + | Seq (loc, [ Prim (_, "GT", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFGT", args, annot)) + | Seq (loc, [ Prim (_, "LE", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFLE", args, annot)) + | Seq (loc, [ Prim (_, "GE", [], _) ; + Prim (_, "IF", args, annot) ]) -> + Some (Prim (loc, "IFGE", args, annot)) + | _ -> None + +let unexpand_asserts expanded = + match expanded with + | Seq (loc, [ Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT", [], [])) + | Seq (loc, [ Seq (_, [ Prim(_, "COMPARE", [], []) ; Prim (_, comparison, [], []) ]) ; + Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], [])) + | Seq (loc, [ Prim (_, comparison, [], []) ; + Prim (_, "IF", [ Seq (_, []) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_" ^ comparison, [], [])) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_NONE", [], annot)) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, []) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_NONE", [], [])) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; + Seq (_, [])], + []) ]) -> + Some (Prim (loc, "ASSERT_SOME", [], [])) + | Seq (loc, [ Prim (_, "IF_NONE", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; + Seq (_, [ Prim (_, "RENAME", [], annot) ])], + []) ]) -> + Some (Prim (loc, "ASSERT_SOME", [], annot)) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, []) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_LEFT", [], [])) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Prim (_, "RENAME", [], annot) ]) ; + Seq (_, [ + Seq (_, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_LEFT", [], annot)) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; + Seq (_, []) ], + []) ]) -> + Some (Prim (loc, "ASSERT_RIGHT", [], [])) + | Seq (loc, [ Prim (_, "IF_LEFT", [ Seq (_, [ Seq (_, [ Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ]) ]) ; + Seq (_, [ Prim (_, "RENAME", [], annot) ]) ], + []) ]) -> + Some (Prim (loc, "ASSERT_RIGHT", [], annot)) + | _ -> None + + +let unexpand_if_some = function + | Seq (loc, [ Prim (_, "IF_NONE", [ left ; right ], annot) ]) -> + Some (Prim (loc, "IF_SOME", [ right ; left ], annot)) + | _ -> None + +let unexpand_if_right = function + | Seq (loc, [ Prim (_, "IF_LEFT", [ left ; right ], annot) ]) -> + Some (Prim (loc, "IF_RIGHT", [ right ; left ], annot)) + | _ -> None + +let unexpand_fail = function + | Seq (loc, [ + Prim (_, "UNIT", [], []) ; + Prim (_, "FAILWITH", [], []) ; + ]) -> + Some (Prim (loc, "FAIL", [], [])) + | _ -> None + +let unexpand original = + let try_unexpansions unexpanders = + match + List.fold_left + (fun acc f -> + match acc with + | None -> f original + | Some rewritten -> Some rewritten) + None unexpanders with + | None -> original + | Some rewritten -> rewritten in + try_unexpansions + [ unexpand_asserts ; + unexpand_caddadr ; + unexpand_set_caddadr ; + unexpand_map_caddadr ; + unexpand_dxiiivp ; + unexpand_pappaiir ; + unexpand_unpappaiir ; + unexpand_duuuuup ; + unexpand_compare ; + unexpand_if_some ; + unexpand_if_right ; + unexpand_fail ] + +let rec unexpand_rec expr = + match unexpand expr with + | Seq (loc, items) -> + Seq (loc, List.map unexpand_rec items) + | Prim (loc, name, args, annot) -> + Prim (loc, name, List.map unexpand_rec args, annot) + | Int _ | String _ | Bytes _ as atom -> atom + +let () = + let open Data_encoding in + register_error_kind + `Permanent + ~id:"michelson.macros.unexpected_annotation" + ~title:"Unexpected annotation" + ~description:"A macro had an annotation, but no annotation was permitted on this macro." + ~pp:(fun ppf -> + Format.fprintf ppf + "Unexpected annotation on macro %s.") + (obj1 + (req "macro_name" string)) + (function + | Unexpected_macro_annotation str -> Some str + | _ -> None) + (fun s -> Unexpected_macro_annotation s) ; + register_error_kind + `Permanent + ~id:"michelson.macros.sequence_expected" + ~title:"Macro expects a sequence" + ~description:"An macro expects a sequence, but a sequence was not provided" + ~pp:(fun ppf name -> + Format.fprintf ppf + "Macro %s expects a sequence, but did not receive one." name) + (obj1 + (req "macro_name" string)) + (function + | Sequence_expected name -> Some name + | _ -> None) + (fun name -> Sequence_expected name) ; + register_error_kind + `Permanent + ~id:"michelson.macros.bas_arity" + ~title:"Wrong number of arguments to macro" + ~description:"A wrong number of arguments was provided to a macro" + ~pp:(fun ppf (name, got, exp) -> + Format.fprintf ppf + "Macro %s expects %d arguments, was given %d." name got exp) + (obj3 + (req "macro_name" string) + (req "given_number_of_arguments" uint16) + (req "expected_number_of_arguments" uint16)) + (function + | Invalid_arity (name, got, exp) -> Some (name, got, exp) + | _ -> None) + (fun (name, got, exp) -> Invalid_arity (name, got, exp)) diff --git a/src/lib_utils/michelson-parser/michelson_v1_macros.mli b/src/lib_utils/michelson-parser/michelson_v1_macros.mli new file mode 100644 index 000000000..4a614cbc0 --- /dev/null +++ b/src/lib_utils/michelson-parser/michelson_v1_macros.mli @@ -0,0 +1,62 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Tezos_micheline + +type 'l node = ('l, string) Micheline.node + +type error += Unexpected_macro_annotation of string +type error += Sequence_expected of string +type error += Invalid_arity of string * int * int + +val expand : 'l node -> 'l node tzresult +val expand_rec : 'l node -> 'l node * error list + +val expand_caddadr : 'l node -> 'l node option tzresult +val expand_set_caddadr : 'l node -> 'l node option tzresult +val expand_map_caddadr : 'l node -> 'l node option tzresult +val expand_dxiiivp : 'l node -> 'l node option tzresult +val expand_pappaiir : 'l node -> 'l node option tzresult +val expand_duuuuup : 'l node -> 'l node option tzresult +val expand_compare : 'l node -> 'l node option tzresult +val expand_asserts : 'l node -> 'l node option tzresult +val expand_unpappaiir : 'l node -> 'l node option tzresult +val expand_if_some : 'l node -> 'l node option tzresult +val expand_if_right : 'l node -> 'l node option tzresult + +val unexpand : 'l node -> 'l node +val unexpand_rec : 'l node -> 'l node + +val unexpand_caddadr : 'l node -> 'l node option +val unexpand_set_caddadr : 'l node -> 'l node option +val unexpand_map_caddadr : 'l node -> 'l node option +val unexpand_dxiiivp : 'l node -> 'l node option +val unexpand_pappaiir : 'l node -> 'l node option +val unexpand_duuuuup : 'l node -> 'l node option +val unexpand_compare : 'l node -> 'l node option +val unexpand_asserts : 'l node -> 'l node option +val unexpand_unpappaiir : 'l node -> 'l node option +val unexpand_if_some : 'l node -> 'l node option +val unexpand_if_right : 'l node -> 'l node option diff --git a/src/lib_utils/michelson-parser/v1.ml b/src/lib_utils/michelson-parser/v1.ml new file mode 100644 index 000000000..1c203482c --- /dev/null +++ b/src/lib_utils/michelson-parser/v1.ml @@ -0,0 +1,91 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Memory_proto_alpha +open Tezos_micheline +open Micheline_parser +open Micheline + +type parsed = + { source : string ; + unexpanded : string canonical ; + expanded : Michelson_v1_primitives.prim canonical ; + expansion_table : (int * (Micheline_parser.location * int list)) list ; + unexpansion_table : (int * int) list } + +(* Unexpanded toplevel expression should be a sequence *) +let expand_all source ast errors = + let unexpanded, loc_table = + extract_locations ast in + let expanded, expansion_errors = + Michelson_v1_macros.expand_rec (root unexpanded) in + let expanded, unexpansion_table = + extract_locations expanded in + let expansion_table = + let sorted = + List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table in + let grouped = + let rec group = function + | acc, [] -> acc + | [], (u, e) :: r -> + group ([ (e, [ u ]) ], r) + | ((pe, us) :: racc as acc), (u, e) :: r -> + if e = pe then + group (((e, u :: us) :: racc), r) + else + group (((e, [ u ]) :: acc), r) in + group ([], sorted) in + List.map2 + (fun (l, ploc) (l', elocs) -> + assert (l = l') ; + (l, (ploc, elocs))) + (List.sort compare loc_table) + (List.sort compare grouped) in + match Alpha_environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded) with + | Ok expanded -> + { source ; unexpanded ; expanded ; + expansion_table ; unexpansion_table }, + errors @ expansion_errors + | Error errs -> + { source ; unexpanded ; + expanded = Micheline.strip_locations (Seq ((), [])) ; + expansion_table ; unexpansion_table }, + errors @ expansion_errors @ errs + +let parse_toplevel ?check source = + let tokens, lexing_errors = Micheline_parser.tokenize source in + let asts, parsing_errors = Micheline_parser.parse_toplevel ?check tokens in + let ast = + let start = min_point asts and stop = max_point asts in + Seq ({ start ; stop }, asts) in + expand_all source ast (lexing_errors @ parsing_errors) + +let parse_expression ?check source = + let tokens, lexing_errors = Micheline_parser.tokenize source in + let ast, parsing_errors = Micheline_parser.parse_expression ?check tokens in + expand_all source ast (lexing_errors @ parsing_errors) + +let expand_all ~source ~original = + expand_all source original [] diff --git a/src/lib_utils/michelson-parser/v1.mli b/src/lib_utils/michelson-parser/v1.mli new file mode 100644 index 000000000..2f0980e32 --- /dev/null +++ b/src/lib_utils/michelson-parser/v1.mli @@ -0,0 +1,51 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) +(* *) +(* Permission is hereby granted, free of charge, to any person obtaining a *) +(* copy of this software and associated documentation files (the "Software"),*) +(* to deal in the Software without restriction, including without limitation *) +(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) +(* and/or sell copies of the Software, and to permit persons to whom the *) +(* Software is furnished to do so, subject to the following conditions: *) +(* *) +(* The above copyright notice and this permission notice shall be included *) +(* in all copies or substantial portions of the Software. *) +(* *) +(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) +(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) +(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) +(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) +(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) +(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) +(* DEALINGS IN THE SOFTWARE. *) +(* *) +(*****************************************************************************) + +open Memory_proto_alpha +open Alpha_context + +open Tezos_micheline + +(** The result of parsing and expanding a Michelson V1 script or data. *) +type parsed = + { + source : string ; + (** The original source code. *) + unexpanded : string Micheline.canonical ; + (** Original expression with macros. *) + expanded : Script.expr ; + (** Expression with macros fully expanded. *) + expansion_table : + (int * (Micheline_parser.location * int list)) list ; + (** Associates unexpanded nodes to their parsing locations and + the nodes expanded from it in the expanded expression. *) + unexpansion_table : (int * int) list ; + (** Associates an expanded node to its source in the unexpanded + expression. *) + } + +val parse_toplevel : ?check:bool -> string -> parsed Micheline_parser.parsing_result +val parse_expression : ?check:bool -> string -> parsed Micheline_parser.parsing_result +val expand_all : source:string -> original:Micheline_parser.node -> parsed Micheline_parser.parsing_result diff --git a/src/lib_utils/tezos-utils.opam b/src/lib_utils/tezos-utils.opam new file mode 100644 index 000000000..c9f4e2a4c --- /dev/null +++ b/src/lib_utils/tezos-utils.opam @@ -0,0 +1,50 @@ +opam-version: "2.0" +name: "tezos-utils" +version: "1.0" +synopsis: "Tezos Utilities defined in the Tezos repository, to be used by other libraries" +maintainer: "Galfour " +authors: "Galfour " +license: "MIT" +homepage: "https://gitlab.com/gabriel.alfour/tezos-utils" +bug-reports: "https://gitlab.com/gabriel.alfour/tezos-utils/issues" +depends: [ + "dune" + "base" + "base" + "bigstring" + "calendar" + "cohttp-lwt-unix" + "cstruct" + "ezjsonm" + "hex" + "hidapi" + "ipaddr" + "irmin" + "js_of_ocaml" + "lwt" + "lwt_log" + "mtime" + "ocplib-endian" + "ocp-ocamlres" + "re" + "rresult" + "stdio" + "uri" + "uutf" + "zarith" + "ocplib-json-typed" + "ocplib-json-typed-bson" + "tezos-crypto" + "tezos-stdlib-unix" + "tezos-data-encoding" + "tezos-protocol-environment" + "tezos-protocol-alpha" + "michelson-parser" +] +build: [ + ["dune" "build" "-p" name] +] +dev-repo: "git+https://gitlab.com/gabriel.alfour/tezos-utils" +url { + src: "https://gitlab.com/gabriel.alfour/tezos-utils/-/archive/master/tezos-utils-master.tar.gz" +} diff --git a/src/lib_utils/tezos_utils.ml b/src/lib_utils/tezos_utils.ml new file mode 100644 index 000000000..a03ee0676 --- /dev/null +++ b/src/lib_utils/tezos_utils.ml @@ -0,0 +1,90 @@ +module Stdlib_unix = Tezos_stdlib_unix +module Crypto = Tezos_crypto +module Data_encoding = Tezos_data_encoding +module Error_monad = X_error_monad +module Signature = Tezos_base.TzPervasives.Signature +module Time = Tezos_base.TzPervasives.Time +module List = X_list +module Option = Tezos_base.TzPervasives.Option +module Cast = Cast +module Micheline = X_tezos_micheline +module Tuple = Tuple + +module Memory_proto_alpha = struct + include Memory_proto_alpha + let init_environment = Init_proto_alpha.init_environment + let dummy_environment = Init_proto_alpha.dummy_environment + + open X_error_monad + open Script_typed_ir + open Script_ir_translator + open Script_interpreter + + let stack_ty_eq (type a b) + ?(tezos_context = dummy_environment.tezos_context) + (a:a stack_ty) (b:b stack_ty) = + alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 a b) >>? fun (Eq, _) -> + ok Eq + + let ty_eq (type a b) + ?(tezos_context = dummy_environment.tezos_context) + (a:a ty) (b:b ty) + = + alpha_wrap (Script_ir_translator.ty_eq tezos_context a b) >>? fun (Eq, _) -> + ok Eq + + let parse_michelson (type aft) + ?(tezos_context = dummy_environment.tezos_context) + ?(top_level = Lambda) (michelson:Micheline.Michelson.t) + (bef:'a Script_typed_ir.stack_ty) (aft:aft Script_typed_ir.stack_ty) + = + let michelson = Micheline.Michelson.strip_annots michelson in + let michelson = Micheline.Michelson.strip_nops michelson in + parse_instr + top_level tezos_context + michelson bef >>=?? fun (j, _) -> + match j with + | Typed descr -> ( + Lwt.return ( + alpha_wrap (Script_ir_translator.stack_ty_eq tezos_context 0 descr.aft aft) >>? fun (Eq, _) -> + let descr : (_, aft) Script_typed_ir.descr = {descr with aft} in + Ok descr + ) + ) + | _ -> Lwt.return @@ error_exn (Failure "Typing instr failed") + + let parse_michelson_data + ?(tezos_context = dummy_environment.tezos_context) + michelson ty = + let michelson = Micheline.Michelson.strip_annots michelson in + let michelson = Micheline.Michelson.strip_nops michelson in + parse_data tezos_context ty michelson >>=?? fun (data, _) -> + return data + + let parse_michelson_ty + ?(tezos_context = dummy_environment.tezos_context) + ?(allow_big_map = true) ?(allow_operation = true) + michelson = + let michelson = Micheline.Michelson.strip_annots michelson in + let michelson = Micheline.Michelson.strip_nops michelson in + Lwt.return @@ parse_ty tezos_context ~allow_big_map ~allow_operation michelson >>=?? fun (ty, _) -> + return ty + + let unparse_michelson_data + ?(tezos_context = dummy_environment.tezos_context) + ?mapper ty value : Micheline.Michelson.t tzresult Lwt.t = + Script_ir_translator.unparse_data tezos_context ?mapper + Readable ty value >>=?? fun (michelson, _) -> + return michelson + + let interpret + ?(tezos_context = dummy_environment.tezos_context) + ?(source = (List.nth dummy_environment.identities 0).implicit_contract) + ?(self = (List.nth dummy_environment.identities 0).implicit_contract) + ?(payer = (List.nth dummy_environment.identities 1).implicit_contract) + ?visitor + (instr:('a, 'b) descr) (bef:'a stack) : 'b stack tzresult Lwt.t = + Script_interpreter.step tezos_context ~source ~self ~payer ?visitor Alpha_context.Tez.one instr bef >>=?? + fun (stack, _) -> return stack + +end diff --git a/src/lib_utils/tuple.ml b/src/lib_utils/tuple.ml new file mode 100644 index 000000000..a32af6f8b --- /dev/null +++ b/src/lib_utils/tuple.ml @@ -0,0 +1,8 @@ +let map2 f (a, b) = (f a, f b) +let apply2 f (a, b) = f a b +let list2 (a, b) = [a;b] + +module Pair = struct + let map = map2 + let apply f (a, b) = f a b +end diff --git a/src/lib_utils/x_error_monad.ml b/src/lib_utils/x_error_monad.ml new file mode 100644 index 000000000..ca28344ea --- /dev/null +++ b/src/lib_utils/x_error_monad.ml @@ -0,0 +1,50 @@ +module Error_monad = Tezos_error_monad.Error_monad +include Error_monad + +let to_string err = + let json = json_of_error err in + Tezos_data_encoding.Json.to_string json + +let print err = + Format.printf "%s\n" @@ to_string err + +let force_ok ?(msg = "") = function + | Ok x -> x + | Error errs -> + Format.printf "Errors :\n"; + List.iter print errs ; + raise @@ Failure ("force_ok : " ^ msg) + +let is_ok = function + | Ok _ -> true + | Error _ -> false + +let force_ok_str ?(msg = "") = function + | Ok x -> x + | Error err -> + Format.printf "Error : %s\n" err; + raise @@ Failure ("force_ok : " ^ msg) + +open Memory_proto_alpha + +let (>>??) = Alpha_environment.Error_monad.(>>?) + +let alpha_wrap a = Alpha_environment.wrap_error a + +let force_ok_alpha ~msg a = force_ok ~msg @@ alpha_wrap a + +let force_lwt ~msg a = force_ok ~msg @@ Lwt_main.run a + +let force_lwt_alpha ~msg a = force_ok ~msg @@ alpha_wrap @@ Lwt_main.run a + +let assert_error () = function + | Ok _ -> fail @@ failure "assert_error" + | Error _ -> return () + +let (>>=??) a f = + a >>= fun a -> + match alpha_wrap a with + | Ok result -> f result + | Error errs -> Lwt.return (Error errs) + + diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml new file mode 100644 index 000000000..9988c8636 --- /dev/null +++ b/src/lib_utils/x_list.ml @@ -0,0 +1,55 @@ +include Tezos_base.TzPervasives.List + +let range n = + let rec aux acc n = + if n = 0 + then acc + else aux ((n-1) :: acc) (n-1) + in + List.rev (aux [] n) + +let find_map f lst = + let rec aux = function + | [] -> None + | hd::tl -> ( + match f hd with + | Some _ as s -> s + | None -> aux tl + ) + in + aux lst + +let find_index f lst = + let rec aux n = function + | [] -> raise (Failure "find_index") + | hd :: _ when f hd -> n + | _ :: tl -> aux (n + 1) tl in + aux 0 lst + +let find_full f lst = + let rec aux n = function + | [] -> raise (Failure "find_index") + | hd :: _ when f hd -> (hd, n) + | _ :: tl -> aux (n + 1) tl in + aux 0 lst + +let assoc_i x lst = + let rec aux n = function + | [] -> raise (Failure "List:assoc_i") + | (x', y) :: _ when x = x' -> (y, n) + | _ :: tl -> aux (n + 1) tl + in + aux 0 lst + +let rec from n lst = + if n = 0 + then lst + else from (n - 1) (tl lst) + +let until n lst = + let rec aux acc n lst = + if n = 0 + then acc + else aux ((hd lst) :: acc) (n - 1) (tl lst) + in + rev (aux [] n lst) diff --git a/src/lib_utils/x_tezos_micheline.ml b/src/lib_utils/x_tezos_micheline.ml new file mode 100644 index 000000000..5ad1fba6e --- /dev/null +++ b/src/lib_utils/x_tezos_micheline.ml @@ -0,0 +1,67 @@ +include Tezos_micheline + +module Michelson = struct + open Micheline + include Memory_proto_alpha.Michelson_v1_primitives + + type michelson = (int, prim) node + type t = michelson + + let prim ?(annot=[]) ?(children=[]) p : michelson = + Prim (0, p, children, annot) + + let annotate annot = function + | Prim (l, p, c, []) -> Prim (l, p, c, [annot]) + | _ -> raise (Failure "annotate") + + let seq s : michelson = Seq (0, s) + + let i_comment s : michelson = prim ~annot:["\"" ^ s ^ "\""] I_NOP + + let int n : michelson = Int (0, n) + let string s : michelson = String (0, s) + let bytes s : michelson = Bytes (0, s) + + let t_unit = prim T_unit + let t_pair a b = prim ~children:[a;b] T_pair + let t_lambda a b = prim ~children:[a;b] T_lambda + + let d_unit = prim D_Unit + let d_pair a b = prim ~children:[a;b] D_Pair + + let i_dup = prim I_DUP + let i_car = prim I_CAR + let i_cdr = prim I_CDR + let i_pair = prim I_PAIR + let i_swap = prim I_SWAP + let i_piar = seq [ i_swap ; i_pair ] + let i_push ty code = prim ~children:[ty;code] I_PUSH + let i_push_unit = i_push t_unit d_unit + let i_lambda arg ret body = prim ~children:[arg;ret;body] I_LAMBDA + let i_drop = prim I_DROP + + let dip code : michelson = prim ~children:[seq [code]] I_DIP + let i_unpair = seq [i_dup ; i_car ; dip i_cdr] + let i_unpiar = seq [i_dup ; i_cdr ; dip i_car] + + let rec strip_annots : michelson -> michelson = function + | Seq(l, s) -> Seq(l, List.map strip_annots s) + | Prim (l, p, lst, _) -> Prim (l, p, List.map strip_annots lst, []) + | x -> x + + let rec strip_nops : michelson -> michelson = function + | Seq(l, s) -> Seq(l, List.map strip_nops s) + | Prim (l, I_NOP, _, _) -> Seq (l, []) + | Prim (l, p, lst, a) -> Prim (l, p, List.map strip_nops lst, a) + | x -> x + + let pp ppf (michelson:michelson) = + let open Micheline_printer in + let canonical = strip_locations michelson in + let node = printable string_of_prim canonical in + print_expr ppf node + + let pp_naked ppf m = + let naked = strip_annots m in + pp ppf naked +end