add tezos-utils

src/lib_utils/.gitignore

@@ -0,0 +1,7 @@
+*.install
+*.merlin
+#*
+*_opam
+*~
+_build/*
+*/_build/*

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

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
+  )
+)

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 ()

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})))

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"
+}

src/lib_utils/michelson-parser/michelson_v1_macros.mli

@@ -0,0 +1,62 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+open 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

src/lib_utils/michelson-parser/v1.ml

@@ -0,0 +1,91 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+open 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 []

src/lib_utils/michelson-parser/v1.mli

@@ -0,0 +1,51 @@
+(*****************************************************************************)
+(*                                                                           *)
+(* Open Source License                                                       *)
+(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
+(*                                                                           *)
+(* Permission is hereby granted, free of charge, to any person obtaining a   *)
+(* copy of this software and associated documentation files (the "Software"),*)
+(* to deal in the Software without restriction, including without limitation *)
+(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
+(* and/or sell copies of the Software, and to permit persons to whom the     *)
+(* Software is furnished to do so, subject to the following conditions:      *)
+(*                                                                           *)
+(* The above copyright notice and this permission notice shall be included   *)
+(* in all copies or substantial portions of the Software.                    *)
+(*                                                                           *)
+(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
+(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
+(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
+(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
+(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
+(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
+(* DEALINGS IN THE SOFTWARE.                                                 *)
+(*                                                                           *)
+(*****************************************************************************)
+
+open 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

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 <gabriel.alfour@gmail.com>"
+authors: "Galfour <gabriel.alfour@gmail.com>"
+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"
+}

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

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

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)
+
+

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)

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