From 84dbf1f7eee30a9d3f8a8363efa5b6f04e7c2f36 Mon Sep 17 00:00:00 2001 From: Galfour Date: Wed, 13 Mar 2019 14:07:17 +0000 Subject: [PATCH] add ligo remove old lib_ligo modified ligo opam --- src/lib_ligo/meta-michelson/.gitignore | 6 - src/lib_ligo/meta-michelson/alpha_wrap.ml | 30 - src/lib_ligo/meta-michelson/contract.ml | 310 ----- src/lib_ligo/meta-michelson/dune | 9 - src/lib_ligo/meta-michelson/json.ml | 7 - .../meta-michelson/meta-michelson.opam | 22 - src/lib_ligo/meta-michelson/meta_michelson.ml | 4 - src/lib_ligo/meta-michelson/michelson_wrap.ml | 514 -------- src/lib_ligo/meta-michelson/misc.ml | 300 ----- src/lib_ligo/meta-michelson/streams.ml | 18 - src/lib_ligo/src/helpers/.gitignore | 6 - src/lib_ligo/src/helpers/dictionary.ml | 33 - src/lib_ligo/src/helpers/dictionary.mli | 16 - src/lib_ligo/src/helpers/dune | 8 - src/lib_ligo/src/helpers/environment.ml | 53 - src/lib_ligo/src/helpers/location.ml | 24 - src/lib_ligo/src/helpers/option.ml | 3 - src/lib_ligo/src/helpers/trace.ml | 157 --- src/lib_ligo/src/helpers/wrap.ml | 21 - src/ligo/bin/cli.ml | 1 + src/ligo/bin/dune | 8 + src/ligo/dune | 20 + src/ligo/lexer.mll | 76 ++ src/ligo/ligo.ml | 5 + .../ligo-helpers.opam => ligo/ligo.opam} | 9 +- src/ligo/main.ml | 461 +++++++ src/ligo/mini_c.ml | 1079 +++++++++++++++++ src/ligo/parser.mly | 200 +++ src/ligo/test/dune | 10 + src/ligo/test/test.ml | 186 +++ 30 files changed, 2051 insertions(+), 1545 deletions(-) delete mode 100644 src/lib_ligo/meta-michelson/.gitignore delete mode 100644 src/lib_ligo/meta-michelson/alpha_wrap.ml delete mode 100644 src/lib_ligo/meta-michelson/contract.ml delete mode 100644 src/lib_ligo/meta-michelson/dune delete mode 100644 src/lib_ligo/meta-michelson/json.ml delete mode 100644 src/lib_ligo/meta-michelson/meta-michelson.opam delete mode 100644 src/lib_ligo/meta-michelson/meta_michelson.ml delete mode 100644 src/lib_ligo/meta-michelson/michelson_wrap.ml delete mode 100644 src/lib_ligo/meta-michelson/misc.ml delete mode 100644 src/lib_ligo/meta-michelson/streams.ml delete mode 100644 src/lib_ligo/src/helpers/.gitignore delete mode 100644 src/lib_ligo/src/helpers/dictionary.ml delete mode 100644 src/lib_ligo/src/helpers/dictionary.mli delete mode 100644 src/lib_ligo/src/helpers/dune delete mode 100644 src/lib_ligo/src/helpers/environment.ml delete mode 100644 src/lib_ligo/src/helpers/location.ml delete mode 100644 src/lib_ligo/src/helpers/option.ml delete mode 100644 src/lib_ligo/src/helpers/trace.ml delete mode 100644 src/lib_ligo/src/helpers/wrap.ml create mode 100644 src/ligo/bin/cli.ml create mode 100644 src/ligo/bin/dune create mode 100644 src/ligo/dune create mode 100644 src/ligo/lexer.mll create mode 100644 src/ligo/ligo.ml rename src/{lib_ligo/src/helpers/ligo-helpers.opam => ligo/ligo.opam} (84%) create mode 100644 src/ligo/main.ml create mode 100644 src/ligo/mini_c.ml create mode 100644 src/ligo/parser.mly create mode 100644 src/ligo/test/dune create mode 100644 src/ligo/test/test.ml diff --git a/src/lib_ligo/meta-michelson/.gitignore b/src/lib_ligo/meta-michelson/.gitignore deleted file mode 100644 index 46d12ff04..000000000 --- a/src/lib_ligo/meta-michelson/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -_build/* -*/_build -*~ -.merlin -*/.merlin -*.install \ No newline at end of file diff --git a/src/lib_ligo/meta-michelson/alpha_wrap.ml b/src/lib_ligo/meta-michelson/alpha_wrap.ml deleted file mode 100644 index 196f6a9c4..000000000 --- a/src/lib_ligo/meta-michelson/alpha_wrap.ml +++ /dev/null @@ -1,30 +0,0 @@ -open Tezos_utils.Error_monad - -let dummy_environment = force_lwt ~msg:"getting dummy env" @@ Misc.init_environment () - -let tc = dummy_environment.tezos_context - -module Proto_alpha = Tezos_utils.Memory_proto_alpha -open Proto_alpha -open Alpha_context -open Alpha_environment - -let pack ty v = fst @@ force_lwt_alpha ~msg:"packing" @@ Script_ir_translator.pack_data tc ty v -let unpack_opt (type a) : a Script_typed_ir.ty -> MBytes.t -> a option = fun ty bytes -> - force_lwt ~msg:"unpacking : parse" ( - if Compare.Int.(MBytes.length bytes >= 1) && - Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05) then - let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in - match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with - | None -> return None - | Some expr -> - Script_ir_translator.parse_data tc ty (Micheline.root expr) >>=?? fun x -> return (Some (fst x)) - else - return None - ) - -let unpack ty a = match unpack_opt ty a with - | None -> raise @@ Failure "unpacking : of_bytes" - | Some x -> x - -let blake2b b = Alpha_environment.Raw_hashes.blake2b b diff --git a/src/lib_ligo/meta-michelson/contract.ml b/src/lib_ligo/meta-michelson/contract.ml deleted file mode 100644 index d5ce41d4c..000000000 --- a/src/lib_ligo/meta-michelson/contract.ml +++ /dev/null @@ -1,310 +0,0 @@ -open Misc - -open Tezos_utils.Error_monad -open Memory_proto_alpha -open Alpha_context - -open Script_ir_translator -open Script_typed_ir - -module Option = Tezos_utils.Option -module Cast = Tezos_utils.Cast - -type ('param, 'storage) toplevel = { - param_type : 'param ty ; - storage_type : 'storage ty ; - code : ('param * 'storage, packed_internal_operation list * 'storage) lambda -} - -type ex_toplevel = - Ex_toplevel : ('a, 'b) toplevel -> ex_toplevel - -let get_toplevel ?environment toplevel_path claimed_storage_type claimed_parameter_type = - let toplevel_str = Streams.read_file toplevel_path in - contextualize ?environment ~msg:"toplevel" @@ fun {tezos_context = context ; _ } -> - let toplevel_expr = Cast.tl_of_string toplevel_str in - let (param_ty_node, storage_ty_node, code_field) = - force_ok_alpha ~msg:"parsing toplevel" @@ - parse_toplevel toplevel_expr in - let (Ex_ty param_type, _) = - force_ok_alpha ~msg:"parse arg ty" @@ - Script_ir_translator.parse_ty context ~allow_big_map:false ~allow_operation:false param_ty_node in - let (Ex_ty storage_type, _) = - force_ok_alpha ~msg:"parse storage ty" @@ - parse_storage_ty context storage_ty_node in - let _ = force_ok_alpha ~msg:"storage eq" @@ Script_ir_translator.ty_eq context storage_type claimed_storage_type in - let _ = force_ok_alpha ~msg:"param eq" @@ Script_ir_translator.ty_eq context param_type claimed_parameter_type in - let param_type_full = Pair_t ((claimed_parameter_type, None, None), - (claimed_storage_type, None, None), None) in - let ret_type_full = - Pair_t ((List_t (Operation_t None, None), None, None), - (claimed_storage_type, None, None), None) in - parse_returning (Toplevel { storage_type = claimed_storage_type ; param_type = claimed_parameter_type }) - context (param_type_full, None) ret_type_full code_field >>=?? fun (code, _) -> - Error_monad.return { - param_type = claimed_parameter_type; - storage_type = claimed_storage_type; - code ; - } - -let make_toplevel code storage_type param_type = - { param_type ; storage_type ; code } - -module type ENVIRONMENT = sig - val identities : identity list - val tezos_context : t -end - -type ex_typed_stack = Ex_typed_stack : ('a stack_ty * 'a Script_interpreter.stack) -> ex_typed_stack - -open Error_monad - -module Step (Env: ENVIRONMENT) = struct - open Env - - type config = { - source : Contract.t option ; - payer : Contract.t option ; - self : Contract.t option ; - visitor : (Script_interpreter.ex_descr_stack -> unit) option ; - timestamp : Script_timestamp.t option ; - debug_visitor : (ex_typed_stack -> unit) option ; - amount : Tez.t option ; - } - - let no_config = { - source = None ; - payer = None ; - self = None ; - visitor = None ; - debug_visitor = None ; - timestamp = None ; - amount = None ; - } - - let of_param base param = match param with - | None -> base - | Some _ as x -> x - - let make_config ?base_config ?source ?payer ?self ?visitor ?debug_visitor ?timestamp ?amount () = - let base_config = Option.unopt ~default:no_config base_config in { - source = Option.first_some source base_config.source ; - payer = Option.first_some payer base_config.payer ; - self = Option.first_some self base_config.self ; - visitor = Option.first_some visitor base_config.visitor ; - debug_visitor = Option.first_some debug_visitor base_config.debug_visitor ; - timestamp = Option.first_some timestamp base_config.timestamp ; - amount = Option.first_some amount base_config.amount ; - } - - open Error_monad - - let debug_visitor ?f () = - let open Script_interpreter in - let aux (Ex_descr_stack (descr, stack)) = - (match (descr.instr, descr.bef) with - | Nop, Item_t (String_t _, stack_ty, _) -> ( - let (Item (s, stack)) = stack in - if s = "_debug" - then ( - match f with - | None -> Format.printf "debug: %s\n%!" @@ Cast.stack_to_string stack_ty stack - | Some f -> f (Ex_typed_stack(stack_ty, stack)) - ) else () - ) - | _ -> ()) ; - () in - aux - - let step_lwt ?(config=no_config) (stack:'a Script_interpreter.stack) (code:('a, 'b) descr) = - let source = Option.unopt - ~default:(List.nth identities 0).implicit_contract config.source in - let payer = Option.unopt - ~default:(List.nth identities 1).implicit_contract config.payer in - let self = Option.unopt - ~default:(List.nth identities 2).implicit_contract config.self in - let amount = Option.unopt ~default:(Tez.one) config.amount in - let visitor = - let default = debug_visitor ?f:config.debug_visitor () in - Option.unopt ~default config.visitor in - let tezos_context = match config.timestamp with - | None -> tezos_context - | Some s -> Alpha_context.Script_timestamp.set_now tezos_context s in - Script_interpreter.step tezos_context ~source ~payer ~self ~visitor amount code stack >>=?? fun (stack, _) -> - return stack - - let step_1_2 ?config (a:'a) (descr:('a * end_of_stack, 'b * ('c * end_of_stack)) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Item(c, Empty))) -> - return (b, c) - - let step_3_1 ?config (a:'a) (b:'b) (c:'c) - (descr:('a * ('b * ('c * end_of_stack)), 'd * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Item(b, Item(c, Empty)))) descr >>=? fun (Item(d, Empty)) -> - return d - - let step_2_1 ?config (a:'a) (b:'b) (descr:('a * ('b * end_of_stack), 'c * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Item(b, Empty))) descr >>=? fun (Item(c, Empty)) -> - return c - - let step_1_1 ?config (a:'a) (descr:('a * end_of_stack, 'b * end_of_stack) descr) = - let open Script_interpreter in - step_lwt ?config (Item(a, Empty)) descr >>=? fun (Item(b, Empty)) -> - return b - - let step_value ?config (a:'a) (descr:('a * end_of_stack, 'a * end_of_stack) descr) = - step_1_1 ?config a descr - - let step ?config stack code = - force_lwt ~msg:"running a step" @@ step_lwt ?config stack code - -end - -let run_lwt_full ?source ?payer ?self toplevel storage param {identities ; tezos_context = context} = - let { code ; _ } = toplevel in - - let source = Option.unopt - ~default:(List.nth identities 0).implicit_contract source in - let payer = Option.unopt - ~default:(List.nth identities 1).implicit_contract payer in - let self = Option.unopt - ~default:(List.nth identities 2).implicit_contract self in - let amount = Tez.one in - - Script_interpreter.interp context ~source ~payer ~self amount code (param, storage) - >>=?? fun ((ops, storage), new_ctxt) -> - let gas = Alpha_context.Gas.consumed ~since:context ~until:new_ctxt in - return (storage, ops, gas) - -let run_lwt ?source ?payer ?self toplevel storage param env = - run_lwt_full ?source ?payer ?self toplevel storage param env >>=? fun (storage, _ops, _gas) -> - return storage - -let run ?environment toplevel storage param = - contextualize ?environment ~msg:"run toplevel" @@ run_lwt toplevel storage param - -let run_node ?environment toplevel storage_node param_node = - contextualize ?environment ~msg:"run toplevel" @@ fun {tezos_context = context ; _} -> - let {param_type ; storage_type ; _ } = toplevel in - parse_data context param_type param_node >>=?? fun (param, _) -> - parse_data context storage_type storage_node >>=?? fun (storage, _) -> - let storage = run toplevel storage param in - unparse_data context Readable storage_type storage >>=?? fun (storage_node, _) -> - return storage_node - -let run_str toplevel storage_str param_str = - let param_node = Cast.node_of_string param_str in - let storage_node = Cast.node_of_string storage_str in - run_node toplevel storage_node param_node - -type input = { - toplevel_path : string ; - storage : string ; - parameter : string -} - -let parse_json json_str : input = - let json = force_ok_str ~msg:"main_contract: invalid json" @@ Tezos_utils.Data_encoding.Json.from_string json_str in - let json = match json with - | `O json -> json - | _ -> raise @@ Failure "main_contract: not recorD" - in - let open Json in - let toplevel_path = force_string ~msg:"main_contract, top_level" @@ List.assoc "top_level" json in - let parameter = force_string ~msg:"main_contract, param" @@ List.assoc "param" json in - let storage = force_string ~msg:"main_contract, storage" @@ List.assoc "storage" json in - { toplevel_path ; storage ; parameter } - -let generate_json (storage_node:Script.node) : string = - let storage_expr = Tezos_micheline.Micheline.strip_locations storage_node in - let json = Data_encoding.Json.construct Script.expr_encoding storage_expr in - Format.fprintf Format.str_formatter "%a" Data_encoding.Json.pp json ; - Format.flush_str_formatter () - -module Types = struct - open Script_typed_ir - - let union a b = Union_t ((a, None), (b, None), None) - let assert_union = function - | Union_t ((a, _), (b, _), _) -> (a, b) - | _ -> assert false - - let pair a b = Pair_t ((a, None, None), (b, None, None), None) - let assert_pair = function - | Pair_t ((a, _, _), ((b, _, _)), _) -> (a, b) - | _ -> assert false - let assert_pair_ex ?(msg="assert pair") (Ex_ty ty) = match ty with - | Pair_t ((a, _, _), ((b, _, _)), _) -> (Ex_ty a, Ex_ty b) - | _ -> raise (Failure msg) - - let unit = Unit_t None - - let bytes = Bytes_t None - let bytes_k = Bytes_key None - - let nat = Nat_t None - let int = Int_t None - let nat_k = Nat_key None - - let big_map k v = Big_map_t (k, v, None) - - let signature = Signature_t None - - let bool = Bool_t None - - let mutez = Mutez_t None - - let string = String_t None - let string_k = String_key None - - let key = Key_t None - - let list a = List_t (a, None) - let assert_list = function - | List_t (a, _) -> a - | _ -> assert false - - let option a = Option_t ((a, None), None, None) - let assert_option = function - | Option_t ((a, _), _, _) -> a - | _ -> assert false - - let address = Address_t None - - let lambda a b = Lambda_t (a, b, None) - let assert_lambda = function - | Lambda_t (a, b, _) -> (a, b) - | _ -> assert false - type ex_lambda = Ex_lambda : (_, _) lambda ty -> ex_lambda - let is_lambda : type a . a ty -> ex_lambda option = function - | Lambda_t (_, _, _) as x -> Some (Ex_lambda x) - | _ -> None - - let timestamp = Timestamp_t None - let timestamp_k = Timestamp_key None - - let map a b = Map_t (a, b, None) - - let assert_type (_:'a ty) (_:'a) = () -end - -module Values = struct - let empty_map t = empty_map t - - let empty_big_map key_type comparable_key_ty value_type : ('a, 'b) big_map = { - key_type ; value_type ; diff = empty_map comparable_key_ty ; - } - - let int n = Script_int.of_int n - - let nat n = Script_int.abs @@ Script_int.of_int n - let nat_to_int n = Option.unopt_exn (Failure "nat_to_int") @@ Script_int.to_int n - - let tez n = Option.unopt_exn (Failure "Values.tez") @@ Tez.of_mutez @@ Int64.of_int n - - let left a = L a - - let right b = R b -end diff --git a/src/lib_ligo/meta-michelson/dune b/src/lib_ligo/meta-michelson/dune deleted file mode 100644 index 7187c4cc2..000000000 --- a/src/lib_ligo/meta-michelson/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name meta_michelson) - (public_name meta-michelson) - (libraries - tezos-utils - michelson-parser - tezos-micheline - ) -) diff --git a/src/lib_ligo/meta-michelson/json.ml b/src/lib_ligo/meta-michelson/json.ml deleted file mode 100644 index 9ed070d0c..000000000 --- a/src/lib_ligo/meta-michelson/json.ml +++ /dev/null @@ -1,7 +0,0 @@ -let force_record ~msg json = match json with - | `O json -> json - | _ -> raise @@ Failure ("not json record : " ^ msg) - -let force_string ~msg json = match json with - | `String str -> str - | _ -> raise @@ Failure ("not json str : " ^ msg) diff --git a/src/lib_ligo/meta-michelson/meta-michelson.opam b/src/lib_ligo/meta-michelson/meta-michelson.opam deleted file mode 100644 index fc81bfadb..000000000 --- a/src/lib_ligo/meta-michelson/meta-michelson.opam +++ /dev/null @@ -1,22 +0,0 @@ -name: "meta-michelson" -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" { build & >= "1.0.1" } - "tezos-utils" - "michelson-parser" -] -build: [ - [ "dune" "build" "-p" name "-j" jobs ] - [ "mv" "src/lib_ligo/meta-michelson/meta-michelson.install" "." ] -] -url { - src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" -} diff --git a/src/lib_ligo/meta-michelson/meta_michelson.ml b/src/lib_ligo/meta-michelson/meta_michelson.ml deleted file mode 100644 index f9cba1a8d..000000000 --- a/src/lib_ligo/meta-michelson/meta_michelson.ml +++ /dev/null @@ -1,4 +0,0 @@ -module Wrap = Michelson_wrap -module Contract = Contract - -let init_environment = Misc.init_environment diff --git a/src/lib_ligo/meta-michelson/michelson_wrap.ml b/src/lib_ligo/meta-michelson/michelson_wrap.ml deleted file mode 100644 index 63d43a369..000000000 --- a/src/lib_ligo/meta-michelson/michelson_wrap.ml +++ /dev/null @@ -1,514 +0,0 @@ -open Tezos_utils.Memory_proto_alpha -module AC = Alpha_context - -module Types = Contract.Types -module Option = Tezos_utils.Option -module MBytes = Alpha_environment.MBytes - -module Stack = struct - open Script_typed_ir - - let descr bef aft instr = - { - loc = 0 ; - bef ; aft ; instr - } - - type nonrec 'a ty = 'a ty - type 'a t = 'a stack_ty - type nonrec ('a, 'b) descr = ('a, 'b) descr - type ('a, 'b) code = ('a t) -> ('a, 'b) descr - - type ex_stack_ty = Ex_stack_ty : 'a t -> ex_stack_ty - type ex_descr = Ex_descr : ('a, 'b) descr -> ex_descr - type ex_code = Ex_code : ('a, 'b) code -> ex_code - - let stack ?annot a b = Item_t (a, b, annot) - let unstack (item: (('a * 'rest) stack_ty)) : ('a ty * 'rest stack_ty) = - let Item_t (hd, tl, _) = item in - (hd, tl) - - let nil = Empty_t - let head x = fst @@ unstack x - let tail x = snd @@ unstack x - - let seq a b bef = - let a_descr = a bef in - let b_descr = b a_descr.aft in - let aft = b_descr.aft in - descr bef aft @@ Seq (a_descr, b_descr) - - let (@>) (stack : 'b t) (code : ('a, 'b) code) = code stack - let (@|) = seq - let (@:) = stack - - let (!:) : ('a, 'b) descr -> ('a, 'b) code = fun d _ -> d - - let (<.) (stack:'a t) (code: ('a, 'b) code): ('a, 'b) descr = code stack - - let (<::) : ('a, 'b) descr -> ('b, 'c) descr -> ('a, 'c) descr = fun ab bc -> - descr ab.bef bc.aft @@ Seq(ab, bc) - - let (<:) (ab_descr:('a, 'b) descr) (code:('b, 'c) code) : ('a, 'c) descr = - let bc_descr = code ab_descr.aft in - ab_descr <:: bc_descr - -end - -open Stack - -type nat = AC.Script_int.n AC.Script_int.num -type int_num = AC.Script_int.z AC.Script_int.num -type bytes = MBytes.t -type address = AC.Contract.t Script_typed_ir.ty -type mutez = AC.Tez.t Script_typed_ir.ty - - -module Stack_ops = struct - open Script_typed_ir - let dup : ('a * 'rest, 'a * ('a * 'rest)) code = fun bef -> - let Item_t (ty, rest, _) = bef in - descr bef (Item_t (ty, Item_t (ty, rest, None), None)) Dup - - let drop : ('a * 'rest, 'rest) code = fun bef -> - let aft = snd @@ unstack bef in - descr bef aft Drop - - let swap (bef : (('a * ('b * 'c)) stack_ty)) = - let Item_t (a, Item_t (b, rest, _), _) = bef in - descr bef (Item_t (b, (Item_t (a, rest, None)), None)) Swap - - let dip code (bef : ('ty * 'rest) stack_ty) = - let Item_t (ty, rest, _) = bef in - let applied = code rest in - let aft = Item_t (ty, applied.aft, None) in - descr bef aft (Dip (code rest)) - - let noop : ('r, 'r) code = fun bef -> - descr bef bef Nop - - let exec : (_, _) code = fun bef -> - let lambda = head @@ tail bef in - let (_, ret) = Types.assert_lambda lambda in - let aft = ret @: (tail @@ tail bef) in - descr bef aft Exec - - let fail aft : ('a * 'r, 'b) code = fun bef -> - let head = fst @@ unstack bef in - descr bef aft (Failwith head) - - let push_string str (bef : 'rest stack_ty) : (_, (string * 'rest)) descr = - let aft = Item_t (Types.string, bef, None) in - descr bef aft (Const (str)) - - let push_none (a:'a ty) : ('rest, 'a option * 'rest) code = fun r -> - let aft = stack (Types.option a) r in - descr r aft (Const None) - - let push_unit : ('rest, unit * 'rest) code = fun r -> - let aft = stack Types.unit r in - descr r aft (Const ()) - - let push_nat n (bef : 'rest stack_ty) : (_, (nat * 'rest)) descr = - let aft = Item_t (Types.nat, bef, None) in - descr bef aft (Const (Contract.Values.nat n)) - - let push_int n (bef : 'rest stack_ty) : (_, (int_num * 'rest)) descr = - let aft = Types.int @: bef in - descr bef aft (Const (Contract.Values.int n)) - - let push_tez n (bef : 'rest stack_ty) : (_, (AC.Tez.tez * 'rest)) descr = - let aft = Types.mutez @: bef in - descr bef aft (Const (Contract.Values.tez n)) - - let push_bool b : ('s, bool * 's) code = fun bef -> - let aft = stack Types.bool bef in - descr bef aft (Const b) - - let push_generic ty v : ('s, _ * 's) code = fun bef -> - let aft = stack ty bef in - descr bef aft (Const v) - - let failstring str aft = - push_string str @| fail aft - -end - -module Stack_shortcuts = struct - open Stack_ops - - let diip c x = dip (dip c) x - let diiip c x = dip (diip c) x - let diiiip c x = dip (diiip c) x - - let bubble_1 = swap - let bubble_down_1 = swap - - let bubble_2 : ('a * ('b * ('c * 'r)), 'c * ('a * ('b * 'r))) code = fun bef -> - bef <. dip swap <: swap - let bubble_down_2 : ('a * ('b * ('c * 'r)), ('b * ('c * ('a * 'r)))) code = fun bef -> - bef <. swap <: dip swap - - let bubble_3 : ('a * ('b * ('c * ('d * 'r))), 'd * ('a * ('b * ('c * 'r)))) code = fun bef -> - bef <. diip swap <: dip swap <: swap - - let keep_1 : type r s . ('a * r, s) code -> ('a * r, 'a * s) code = fun code bef -> - bef <. dup <: dip code - - let save_1_1 : type r . ('a * r, 'b * r) code -> ('a * r, 'b * ('a * r)) code = fun code s -> - s <. keep_1 code <: swap - - let keep_2 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), ('a * ('b * s))) code = fun code bef -> - (dup @| dip (swap @| dup @| dip (swap @| code))) bef - - let keep_2_1 : type r s . ('a * ('b * r), s) code -> ('a * ('b * r), 'b * s) code = fun code bef -> - (dip dup @| swap @| dip code) bef - - let relativize_1_1 : ('a * unit, 'b * unit) descr -> ('a * 'r, 'b * 'r) code = fun d s -> - let aft = head d.aft @: tail s in - descr s aft d.instr - -end - -module Pair_ops = struct - let car (bef : (('a * 'b) * 'rest) Stack.t) = - let (pair, rest) = unstack bef in - let (a, _) = Contract.Types.assert_pair pair in - descr bef (stack a rest) Car - - let cdr (bef : (('a * 'b) * 'rest) Stack.t) = - let (pair, rest) = unstack bef in - let (_, b) = Contract.Types.assert_pair pair in - descr bef (stack b rest) Cdr - - let pair (bef : ('a * ('b * 'rest)) Stack.t) = - let (a, rest) = unstack bef in - let (b, rest) = unstack rest in - let aft = (Types.pair a b) @: rest in - descr bef aft Cons_pair - - open Stack_ops - let carcdr s = s <. car <: Stack_ops.dip cdr - - let cdrcar s = s <. cdr <: dip car - - let cdrcdr s = s <. cdr <: dip cdr - - let carcar s = s <. car <: dip car - - let cdar s = s <. cdr <: car - - let unpair s = s <. dup <: car <: dip cdr -end - -module Option_ops = struct - open Script_typed_ir - - let cons bef = - let (hd, tl) = unstack bef in - descr bef (stack (Contract.Types.option hd) tl) Cons_some - - let cond ?target none_branch some_branch : ('a option * 'r, 'b) code = fun bef -> - let (a_opt, base) = unstack bef in - let a = Types.assert_option a_opt in - let target = Option.unopt ~default:(none_branch base).aft target in - descr bef target (If_none (none_branch base, some_branch (stack a base))) - - let force_some ?msg : ('a option * 'r, 'a * 'r) code = fun s -> - let (a_opt, base) = unstack s in - let a = Types.assert_option a_opt in - let target = a @: base in - cond ~target - (Stack_ops.failstring ("force_some : " ^ Option.unopt ~default:"" msg) target) - Stack_ops.noop s -end - -module Union_ops = struct - open Script_typed_ir - - let left (b:'b ty) : ('a * 'r, ('a, 'b) union * 'r) code = fun bef -> - let (a, base) = unstack bef in - let aft = Types.union a b @: base in - descr bef aft Left - - let right (a:'a ty) : ('b * 'r, ('a, 'b) union * 'r) code = fun bef -> - let (b, base) = unstack bef in - let aft = Types.union a b @: base in - descr bef aft Right - - - let loop ?after (code: ('a * 'r, ('a, 'b) union * 'r) code): (('a, 'b) union * 'r, 'b * 'r) code = fun bef -> - let (union, base) = unstack bef in - let (a, b) = Types.assert_union union in - let code_stack = a @: base in - let aft = Option.unopt ~default:(b @: base) after in - descr bef aft (Loop_left (code code_stack)) - -end - -module Arithmetic = struct - let neq : (int_num * 'r, bool *'r) code = fun bef -> - let aft = stack Types.bool @@ snd @@ unstack bef in - descr bef aft Neq - - let neg : (int_num * 'r, int_num *'r) code = fun bef -> - let aft = stack Types.int @@ snd @@ unstack bef in - descr bef aft Neg_int - - let abs : (int_num * 'r, nat *'r) code = fun bef -> - let aft = stack Types.nat @@ snd @@ unstack bef in - descr bef aft Abs_int - - let int : (nat * 'r, int_num*'r) code = fun bef -> - let aft = stack Types.int @@ snd @@ unstack bef in - descr bef aft Int_nat - - let nat_opt : (int_num * 'r, nat option * 'r) code = fun bef -> - let aft = stack Types.(option nat) @@ tail bef in - descr bef aft Is_nat - - let nat_neq = fun s -> (int @| neq) s - - let add_natnat (bef : (nat * (nat * 'rest)) Stack.t) = - let (nat, rest) = unstack bef in - let rest = tail rest in - let aft = stack nat rest in - descr bef aft Add_natnat - - let add_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = - let (nat, rest) = unstack bef in - let rest = tail rest in - let aft = stack nat rest in - descr bef aft Add_intint - - let add_teztez : (AC.Tez.tez * (AC.Tez.tez * 'rest), _) code = fun bef -> - let aft = tail bef in - descr bef aft Add_tez - - let mul_natnat (bef : (nat * (nat * 'rest)) Stack.t) = - let nat = head bef in - let rest = tail @@ tail bef in - let aft = stack nat rest in - descr bef aft Mul_natnat - - let mul_intint (bef : (int_num * (int_num * 'rest)) Stack.t) = - let nat = head bef in - let rest = tail @@ tail bef in - let aft = stack nat rest in - descr bef aft Mul_intint - - let sub_intint : (int_num * (int_num * 'r), int_num * 'r) code = fun bef -> - let aft = tail bef in - descr bef aft Sub_int - - let sub_natnat : (nat * (nat * 'r), int_num * 'r) code = - fun bef -> bef <. int <: Stack_ops.dip int <: sub_intint - - let ediv : (nat * (nat * 'r), (nat * nat) option * 'r) code = fun s -> - let (n, base) = unstack @@ snd @@ unstack s in - let aft = Types.option (Types.pair n n) @: base in - descr s aft Ediv_natnat - - let ediv_tez = fun s -> - let aft = Types.(option @@ pair (head s) (head s)) @: tail @@ tail s in - descr s aft Ediv_teznat - - open Option_ops - let force_ediv x = x <. ediv <: force_some - let force_ediv_tez x = (ediv_tez @| force_some) x - - open Pair_ops - let div x = x <. force_ediv <: car - - open Stack_ops - let div_n n s = s <. push_nat n <: swap <: div - let add_n n s = s <. push_nat n <: swap <: add_natnat - let add_teztez_n n s = s <. push_tez n <: swap <: add_teztez - let sub_n n s = s <. push_nat n <: swap <: sub_natnat - - let force_nat s = s <. nat_opt <: force_some ~msg:"force nat" -end - -module Boolean = struct - let bool_and (type r) : (bool * (bool * r), bool * r) code = fun bef -> - let aft = Types.bool @: tail @@ tail bef in - descr bef aft And - - let bool_or (type r) : (bool * (bool * r), bool * r) code = fun bef -> - let aft = Types.bool @: tail @@ tail bef in - descr bef aft Or - - open Script_typed_ir - let cond ?target true_branch false_branch : (bool * 'r, 's) code = fun bef -> - let base = tail bef in - let aft = Option.unopt ~default:((true_branch base).aft) target in - descr bef aft (If (true_branch base, false_branch base)) - - let loop (code : ('s, bool * 's) code) : ((bool * 's), 's) code = fun bef -> - let aft = tail bef in - descr bef aft @@ Loop (code aft) - -end - -module Comparison_ops = struct - let cmp c_ty : _ code = fun bef -> - let aft = stack Contract.Types.int @@ tail @@ tail @@ bef in - descr bef aft (Compare c_ty) - - let cmp_bytes = fun x -> cmp (Bytes_key None) x - - let eq : (int_num * 'r, bool *'r) code = fun bef -> - let aft = stack Contract.Types.bool @@ snd @@ unstack bef in - descr bef aft Eq - - open Arithmetic - let eq_n n s = s <. sub_n n <: eq - - let ge : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Ge - - let gt : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Gt - - let lt : (int_num * 'r, bool * 'r) code = fun bef -> - let base = tail bef in - let aft = stack Types.bool base in - descr bef aft Lt - - let gt_nat s = s <. int <: gt - - open Stack_ops - let assert_positive_nat s = s <. dup <: gt_nat <: Boolean.cond noop (failstring "positive" s) - - let cmp_ge_nat : (nat * (nat * 'r), bool * 'r) code = fun bef -> - bef <. sub_natnat <: ge - - let cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), bool * 'r) code = fun bef -> - bef <. cmp Types.timestamp_k <: ge - - let assert_cmp_ge_nat : (nat * (nat * 'r), 'r) code = fun bef -> - bef <. cmp_ge_nat <: Boolean.cond noop (failstring "assert cmp ge nat" (tail @@ tail bef)) - - let assert_cmp_ge_timestamp : (AC.Script_timestamp.t * (AC.Script_timestamp.t * 'r), 'r) code = fun bef -> - bef <. cmp_ge_timestamp <: Boolean.cond noop (failstring "assert cmp ge timestamp" (tail @@ tail bef)) -end - - -module Bytes = struct - - open Script_typed_ir - - let pack (ty:'a ty) : ('a * 'r, bytes * 'r) code = fun bef -> - let aft = stack Types.bytes @@ tail bef in - descr bef aft (Pack ty) - - let unpack_opt : type a . a ty -> (bytes * 'r, a option * 'r) code = fun ty bef -> - let aft = stack (Types.option ty) (tail bef) in - descr bef aft (Unpack ty) - - let unpack ty s = s <. unpack_opt ty <: Option_ops.force_some - - let concat : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) code = fun bef -> - let aft = tail bef in - descr bef aft Concat_bytes_pair - - let sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> - descr bef bef Sha256 - - let blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) code = fun bef -> - descr bef bef Blake2b -end - - -module Map = struct - open Script_typed_ir - - type ('a, 'b) t = ('a, 'b) map - - let empty c_ty = Script_ir_translator.empty_map c_ty - let set (type a b) m (k:a) (v:b) = Script_ir_translator.map_update k (Some v) m - - module Ops = struct - let update (bef : (('a * ('b option * (('a, 'b) map * ('rest)))) Stack.t)) : (_, ('a, 'b) map * 'rest) descr = - let Item_t (_, Item_t (_, Item_t (map, rest, _), _), _) = bef in - let aft = Item_t (map, rest, None) in - descr bef aft Map_update - - let get : ?a:('a ty) -> 'b ty -> ('a * (('a, 'b) map * 'r), 'b option * 'r) code = fun ?a b bef -> - let _ = a in - let base = snd @@ unstack @@ snd @@ unstack bef in - let aft = stack (Types.option b) base in - descr bef aft Map_get - - let big_get : 'a ty -> 'b ty -> ('a * (('a, 'b) big_map * 'r), 'b option * 'r) code = fun _a b bef -> - let base = snd @@ unstack @@ snd @@ unstack bef in - let aft = stack (Types.option b) base in - descr bef aft Big_map_get - - let big_update : ('a * ('b option * (('a, 'b) big_map * 'r)), ('a, 'b) big_map * 'r) code = fun bef -> - let base = tail @@ tail bef in - descr bef base Big_map_update - end -end - -module List_ops = struct - let nil ele bef = - let aft = stack (Types.list ele) bef in - descr bef aft Nil - - let cons bef = - let aft = tail bef in - descr bef aft Cons_list - - let cond ~target cons_branch nil_branch bef = - let (lst, aft) = unstack bef in - let a = Types.assert_list lst in - let cons_descr = cons_branch (a @: Types.list a @: aft) in - let nil_descr = nil_branch aft in - descr bef target (If_cons (cons_descr, nil_descr)) - - let list_iter : type a r . (a * r, r) code -> (a list * r, r) code = fun code bef -> - let (a_lst, aft) = unstack bef in - let a = Types.assert_list a_lst in - descr bef aft (List_iter (code (a @: aft))) - -end - -module Tez = struct - - let amount : ('r, AC.Tez.t * 'r) code = fun bef -> - let aft = Types.mutez @: bef in - descr bef aft Amount - - open Bytes - - let tez_nat s = s <. pack Types.mutez <: unpack Types.nat - let amount_nat s = s <. amount <: pack Types.mutez <: unpack Types.nat -end - -module Misc = struct - - open Stack_ops - open Stack_shortcuts - open Comparison_ops - let min_nat : (nat * (nat * 'r), nat * 'r) code = fun s -> - s <. - keep_2 cmp_ge_nat <: bubble_2 <: - Boolean.cond drop (dip drop) - - let debug ~msg () s = s <. push_string msg <: push_string "_debug" <: noop <: drop <: drop - - let debug_msg msg = debug ~msg () - - let now : ('r, AC.Script_timestamp.t * 'r) code = fun bef -> - let aft = stack Types.timestamp bef in - descr bef aft Now - -end - - - diff --git a/src/lib_ligo/meta-michelson/misc.ml b/src/lib_ligo/meta-michelson/misc.ml deleted file mode 100644 index 622b283d7..000000000 --- a/src/lib_ligo/meta-michelson/misc.ml +++ /dev/null @@ -1,300 +0,0 @@ -module Signature = Tezos_base.TzPervasives.Signature -open Tezos_utils.Memory_proto_alpha -module Data_encoding = Alpha_environment.Data_encoding -module MBytes = Alpha_environment.MBytes -module Error_monad = Tezos_utils.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) - (Tezos_utils.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_utils.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 header = { - Alpha_context.Block_header.shell = { - predecessor = hash ; - proto_level = header.proto_level ; - validation_passes = header.validation_passes ; - fitness = header.fitness ; - timestamp ; - level = header.level ; - context = Alpha_environment.Context_hash.zero ; - operations_hash = Alpha_environment.Operation_list_list_hash.zero ; - } ; - protocol_data = { - contents ; - signature = Signature.zero ; - } ; - } in - Main.begin_construction - ~chain_id: Alpha_environment.Chain_id.zero - ~predecessor_context: ctxt - ~predecessor_timestamp: header.shell.timestamp - ~predecessor_fitness: header.shell.fitness - ~predecessor_level: header.shell.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 diff --git a/src/lib_ligo/meta-michelson/streams.ml b/src/lib_ligo/meta-michelson/streams.ml deleted file mode 100644 index b45176516..000000000 --- a/src/lib_ligo/meta-michelson/streams.ml +++ /dev/null @@ -1,18 +0,0 @@ -let read_file f = - let ic = open_in f in - let n = in_channel_length ic in - let s = Bytes.create n in - really_input ic s 0 n; - close_in ic; - Bytes.to_string s - -let read_lines filename = - let lines = ref [] in - let chan = open_in filename in - try - while true; do - lines := input_line chan :: !lines - done; !lines - with End_of_file -> - close_in chan; - List.rev !lines diff --git a/src/lib_ligo/src/helpers/.gitignore b/src/lib_ligo/src/helpers/.gitignore deleted file mode 100644 index 46d12ff04..000000000 --- a/src/lib_ligo/src/helpers/.gitignore +++ /dev/null @@ -1,6 +0,0 @@ -_build/* -*/_build -*~ -.merlin -*/.merlin -*.install \ No newline at end of file diff --git a/src/lib_ligo/src/helpers/dictionary.ml b/src/lib_ligo/src/helpers/dictionary.ml deleted file mode 100644 index a4badb866..000000000 --- a/src/lib_ligo/src/helpers/dictionary.ml +++ /dev/null @@ -1,33 +0,0 @@ -open Trace - -type ('a, 'b) t = ('a * 'b) list - -let get_exn x y = List.assoc y x - -let get x y = generic_try (simple_error "Dictionry.get") @@ fun () -> get_exn x y - -let set ?equal lst a b = - let equal : 'a -> 'a -> bool = - Option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux ((key, b) :: acc) tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - -let del ?equal lst a = - let equal : 'a -> 'a -> bool = - Option.unopt - ~default:(=) equal - in - let rec aux acc = function - | [] -> List.rev acc - | (key, _)::tl when equal key a -> aux acc tl - | hd::tl -> aux (hd :: acc) tl - in - aux [] lst - -let to_list x = x diff --git a/src/lib_ligo/src/helpers/dictionary.mli b/src/lib_ligo/src/helpers/dictionary.mli deleted file mode 100644 index 10204b467..000000000 --- a/src/lib_ligo/src/helpers/dictionary.mli +++ /dev/null @@ -1,16 +0,0 @@ -open Trace - -type ('a, 'b) t - -val get_exn : ('a, 'b) t -> 'a -> 'b -val get : ('a, 'b) t -> 'a -> 'b result - -val set : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t - -val del : - ?equal:('a -> 'a -> bool) -> - ('a, 'b) t -> 'a -> ('a, 'b) t - -val to_list : ('a, 'b) t -> ('a * 'b) list diff --git a/src/lib_ligo/src/helpers/dune b/src/lib_ligo/src/helpers/dune deleted file mode 100644 index f3d586dbf..000000000 --- a/src/lib_ligo/src/helpers/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (libraries - tezos-base - tezos-utils - ) - (name ligo_helpers) - (public_name ligo-helpers) -) diff --git a/src/lib_ligo/src/helpers/environment.ml b/src/lib_ligo/src/helpers/environment.ml deleted file mode 100644 index ecb5839d2..000000000 --- a/src/lib_ligo/src/helpers/environment.ml +++ /dev/null @@ -1,53 +0,0 @@ -module type PARAMETER = sig - type key - type value - val key_cmp : key -> key -> int - val value_cmp : value -> value -> int -end - -let parameter (type key value) ?key_cmp ?value_cmp () : (module PARAMETER with type key = key and type value = value) = - (module struct - type nonrec key = key - type nonrec value = value - let key_cmp = Option.unopt ~default:compare key_cmp - let value_cmp = Option.unopt ~default:compare value_cmp - end) - -let int_parameter = (parameter () : (module PARAMETER with type key = int and type value = int)) -module INT_PARAMETER = (val ((parameter () : (module PARAMETER with type key = int and type value = int)))) - -module type ENVIRONMENT = sig - type key - type value - type t - - val empty : t - val get_opt : t -> key -> value option - val gets : t -> key -> value list - val set : t -> key -> value -> t - val del : t -> key -> t -end - -module Make(P:PARAMETER) : ENVIRONMENT with type key = P.key and type value = P.value = struct - type key = P.key - type value = P.value - type t = (key * value) list - - let empty : t = [] - - let gets lst k = - let kvs = List.filter (fun (k', _) -> P.key_cmp k k' = 0) lst in - List.map snd kvs - let get_opt lst k = match gets lst k with - | [] -> None - | v :: _ -> Some v - - let set lst k v = (k, v) :: lst - - let del lst k = - let rec aux acc = function - | [] -> List.rev acc - | (key, _) :: tl when P.key_cmp key k = 0 -> List.rev acc @ tl - | hd :: tl -> aux (hd :: acc) tl in - aux [] lst -end diff --git a/src/lib_ligo/src/helpers/location.ml b/src/lib_ligo/src/helpers/location.ml deleted file mode 100644 index 776cd7f93..000000000 --- a/src/lib_ligo/src/helpers/location.ml +++ /dev/null @@ -1,24 +0,0 @@ -type file_location = { - filename : string ; - start_line : int ; - start_column : int ; - end_line : int ; - end_column : int ; -} - -type virtual_location = string - -type t = - | File of file_location - | Virtual of virtual_location - -let make (start_pos:Lexing.position) (end_pos:Lexing.position) : t = - let filename = start_pos.pos_fname in - let start_line = start_pos.pos_lnum in - let end_line = end_pos.pos_lnum in - let start_column = start_pos.pos_cnum - start_pos.pos_bol in - let end_column = end_pos.pos_cnum - end_pos.pos_bol in - File { filename ; start_line ; start_column ; end_line ; end_column } - -let virtual_location s = Virtual s -let dummy = virtual_location "dummy" diff --git a/src/lib_ligo/src/helpers/option.ml b/src/lib_ligo/src/helpers/option.ml deleted file mode 100644 index 4ee7859ff..000000000 --- a/src/lib_ligo/src/helpers/option.ml +++ /dev/null @@ -1,3 +0,0 @@ -let unopt ~default = function - | None -> default - | Some x -> x diff --git a/src/lib_ligo/src/helpers/trace.ml b/src/lib_ligo/src/helpers/trace.ml deleted file mode 100644 index a99e7ea8b..000000000 --- a/src/lib_ligo/src/helpers/trace.ml +++ /dev/null @@ -1,157 +0,0 @@ -type error = { - message : string ; - title : string ; -} - -type 'a result = - Ok of 'a - | Errors of error list - -let ok x = Ok x -let fail err = Errors [err] - -let simple_error str = { - message = "" ; - title = str ; -} - -let error title message = { title ; message } - -let simple_fail str = fail @@ simple_error str - -let map f = function - | Ok x -> f x - | Errors _ as e -> e - -let apply f = function - | Ok x -> Ok (f x) - | Errors _ as e -> e - -let (>>?) x f = map f x -let (>>|?) = apply - -module Let_syntax = struct - let bind m ~f = m >>? f -end - -let trace err = function - | Ok _ as o -> o - | Errors errs -> Errors (err :: errs) - -let trace_option error = function - | None -> fail error - | Some s -> ok s - -let rec bind_list = function - | [] -> ok [] - | hd :: tl -> ( - hd >>? fun hd -> - bind_list tl >>? fun tl -> - ok @@ hd :: tl - ) - -let bind_or (a, b) = - match a with - | Ok x -> ok x - | _ -> b - -let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = - match (a, b) with - | Ok x, _ -> ok @@ `Left x - | _, Ok x -> ok @@ `Right x - | _, Errors b -> Errors b - -let bind_and (a, b) = - a >>? fun a -> - b >>? fun b -> - ok (a, b) - -module AE = Tezos_utils.Memory_proto_alpha.Alpha_environment -module TP = Tezos_base__TzPervasives - -let of_tz_error (err:Tezos_utils.Error_monad.error) : error = - let str = Tezos_utils.Error_monad.(to_string err) in - error "alpha error" str - -let of_alpha_tz_error err = of_tz_error (AE.Ecoproto_error err) - -let trace_alpha_tzresult err : 'a AE.Error_monad.tzresult -> 'a result = - function - | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_alpha_tz_error errs) - -let trace_alpha_tzresult_lwt error (x:_ AE.Error_monad.tzresult Lwt.t) : _ result = - trace_alpha_tzresult error @@ Lwt_main.run x - -let trace_tzresult err = - function - | Result.Ok x -> ok x - | Error errs -> Errors (err :: List.map of_tz_error errs) - -let trace_tzresult_lwt err (x:_ TP.Error_monad.tzresult Lwt.t) : _ result = - trace_tzresult err @@ Lwt_main.run x - -let generic_try err f = - try ( - ok @@ f () - ) with _ -> fail err - -let specific_try handler f = - try ( - ok @@ f () - ) with exn -> fail (handler exn) - -let sequence f lst = - let rec aux acc = function - | hd :: tl -> ( - match f hd with - | Ok x -> aux (x :: acc) tl - | Errors _ as errs -> errs - ) - | [] -> ok @@ List.rev acc in - aux [] lst - -let error_pp fmt error = - if error.message = "" - then Format.fprintf fmt "%s" error.title - else Format.fprintf fmt "%s : %s" error.title error.message - -let error_pp_short fmt error = - Format.fprintf fmt "%s" error.title - -let errors_pp = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp - -let errors_pp_short = - Format.pp_print_list - ~pp_sep:Format.pp_print_newline - error_pp_short - -let pp_to_string pp () x = - Format.fprintf Format.str_formatter "%a" pp x ; - Format.flush_str_formatter () - -let errors_to_string = pp_to_string errors_pp - -module Assert = struct - let assert_true ~msg = function - | true -> ok () - | false -> simple_fail msg - - let assert_equal_int ?msg a b = - let msg = Option.unopt ~default:"not equal int" msg in - assert_true ~msg (a = b) - - let assert_list_size ~msg lst n = - assert_true ~msg (List.length lst = n) - - let assert_list_size_2 ~msg = function - | [a;b] -> ok (a, b) - | _ -> simple_fail msg - - let assert_list_size_1 ~msg = function - | [a] -> ok a - | _ -> simple_fail msg -end diff --git a/src/lib_ligo/src/helpers/wrap.ml b/src/lib_ligo/src/helpers/wrap.ml deleted file mode 100644 index 2a9b1eab4..000000000 --- a/src/lib_ligo/src/helpers/wrap.ml +++ /dev/null @@ -1,21 +0,0 @@ -module Make (P : sig type meta end) = struct - type meta = P.meta - type 'value t = { - value : 'value ; - meta : meta ; - } - - let make meta value = { value ; meta } - let value t = t.value - let meta t = t.meta - - let apply : ('a -> 'b) -> 'a t -> 'b = fun f x -> f x.value -end - -module Location = struct - include Make(struct type meta = Location.t end) - - let make_f f : loc:_ -> _ -> _ t = fun ~loc x -> make loc (f x) - let make ~loc x : _ t = make loc x - let update_location ~loc t = {t with meta = loc} -end diff --git a/src/ligo/bin/cli.ml b/src/ligo/bin/cli.ml new file mode 100644 index 000000000..06135b4a4 --- /dev/null +++ b/src/ligo/bin/cli.ml @@ -0,0 +1 @@ +let () = print_int 42 diff --git a/src/ligo/bin/dune b/src/ligo/bin/dune new file mode 100644 index 000000000..5f8246925 --- /dev/null +++ b/src/ligo/bin/dune @@ -0,0 +1,8 @@ +(executable + (name cli) + (public_name ligo) + (package ligo) + (preprocess + (pps ppx_let) + ) +) diff --git a/src/ligo/dune b/src/ligo/dune new file mode 100644 index 000000000..7ec8e668f --- /dev/null +++ b/src/ligo/dune @@ -0,0 +1,20 @@ +(ocamllex + (modules lexer)) + +(menhir + (modules parser)) + +(library + (name ligo) + (public_name ligo) + (libraries + tezos-utils + tezos-micheline + meta-michelson + ligo-helpers + ) + (preprocess + (pps ppx_let) + ) + (flags (:standard -w +1..62-4-44-40-42-9@39@33 )) +) diff --git a/src/ligo/lexer.mll b/src/ligo/lexer.mll new file mode 100644 index 000000000..85f6aec00 --- /dev/null +++ b/src/ligo/lexer.mll @@ -0,0 +1,76 @@ +{ + open Parser + + exception Error of string + exception Unexpected_character of string +} + +(* This rule analyzes a single line and turns it into a stream of + tokens. *) + +rule token = parse +(* + | "//" ([^ '\n']* ) (['\n' '\r']+) + { Lexing.new_line lexbuf ; token lexbuf } +*) +| ('\r'? '\n' '\r'?) + { Lexing.new_line lexbuf; token lexbuf } +| [' ' '\t'] + { token lexbuf } +| '"' ( [^ '"' '\\'] | ( '\\' [^ '"'] ) ) as s '"' + { STRING s } +| "let" { LET } +| "if" { IF } +(* | "then" { THEN } *) +| "elseif" { ELSEIF } +| "else" { ELSE } +(* | "in" { IN } *) +| "type" { TYPE } +| "function" { FUNCTION } +| "while" + { WHILE } +| "foreach" + { FOREACH } +| "of" + { OF } +| (['a'-'z']['a'-'z''A'-'Z''0'-'9''_']+) as v + { VAR_NAME v } +| (['A'-'Z']['a'-'z''A'-'Z''0'-'9''_']+) as t + { TYPE_NAME t } +(* | ['0'-'9']+'.'['0'-'9']* as i { FLOAT (float_of_string i) } *) +| ['0'-'9']+ as i + { INT (int_of_string i) } +(* + | '+' { PLUS } + | '-' { MINUS } + | '*' { TIMES } + | '/' { DIV } + | ";;" { DOUBLE_SEMICOLON } +*) +| '=' { EQUAL } +| ',' { COMMA } +| ';' { SEMICOLON } +| ':' { COLON } +| '&' + { AND } +| '|' + { AND } +| '.' + { DOT } +| '@' + { AT } +| '(' + { LPAREN } +| ')' + { RPAREN } +(* + | '[' { LSQUARE } + | ']' { RSQUARE } +*) +| '{' + { LBRACKET } +| '}' + { RBRACKET } +| eof { EOF } +| _ + { raise (Unexpected_character (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) } diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml new file mode 100644 index 000000000..28f431fa9 --- /dev/null +++ b/src/ligo/ligo.ml @@ -0,0 +1,5 @@ +include Main + +module Mini_c = Mini_c +module Parser = Parser +module Lexer = Lexer diff --git a/src/lib_ligo/src/helpers/ligo-helpers.opam b/src/ligo/ligo.opam similarity index 84% rename from src/lib_ligo/src/helpers/ligo-helpers.opam rename to src/ligo/ligo.opam index 4f2cf5cb5..c2f5664c1 100644 --- a/src/lib_ligo/src/helpers/ligo-helpers.opam +++ b/src/ligo/ligo.opam @@ -1,4 +1,3 @@ -name: "ligo-helpers" opam-version: "2.0" version: "1.0" maintainer: "gabriel.alfour@gmail.com" @@ -10,14 +9,16 @@ license: "MIT" depends: [ "ocamlfind" { build } "dune" { build & >= "1.0.1" } - "meta-michelson" + "menhir" + "ppx_let" "tezos-utils" - "tezos-base" + "meta-michelson" + "ligo-helpers" ] build: [ [ "dune" "build" "-p" name "-j" jobs ] - [ "mv" "src/lib_ligo/src/helpers/ligo-helpers.install" "." ] ] + url { src: "https://gitlab.com/gabriel.alfour/tezos/-/archive/master/tezos.tar.gz" } diff --git a/src/ligo/main.ml b/src/ligo/main.ml new file mode 100644 index 000000000..5b937b980 --- /dev/null +++ b/src/ligo/main.ml @@ -0,0 +1,461 @@ +(* -*- compile-command: "cd .. ; dune build -p ligo" -*- *) + +open Ligo_helpers +open Trace + +module Untyped = struct + module WrapLocation = Wrap.Location + let wrap = Wrap.Location.make + + module Type = struct + type name = string + + type base = [ + | `Unit + | `Bool + | `Int + | `Nat + ] + + let unit : base = `Unit + let bool : base = `Bool + let int : base = `Int + let nat : base = `Nat + + type 'a node = [ + | `Pair of 'a * 'a + | `Or of 'a * 'a + ] + + type expression_ast = [ + | expression node + | base + | `Name of name + ] + + and expression = expression_ast WrapLocation.t + + let pair ~loc a b : expression = wrap ~loc (`Pair(a,b)) + let union ~loc a b : expression = wrap ~loc (`Or(a,b)) + let name ~loc s : expression = + wrap ~loc (match s with + | "Unit" -> (unit :> expression_ast) + | "Bool" -> (bool :> expression_ast) + | "Int" -> (int :> expression_ast) + | "Nat" -> (nat :> expression_ast) + | s -> `Name s) + end + + module Value = struct + type name = string + type function_name = string + + type constant = [ + | `Int of int + ] + + type expression = [ + | `Variable of name + | `Pair of expression * expression + | `Application of expression * expression + | `Constant of constant + ] WrapLocation.t + + type assignment = [ + | `Let of name * expression + | `Type of Type.name * Type.expression + | `Function of function_name * Type.expression * block + ] WrapLocation.t + + and statement = [ + | `Assignment of assignment + | `ForEach of name * expression * block + | `While of expression * block + | `Condition of expression * block * (expression * block) list * block option + ] WrapLocation.t + + and block = statement list WrapLocation.t + + and program = assignment list WrapLocation.t + + type 'a wrapper = loc:Location.t -> 'a -> 'a WrapLocation.t + let int = (WrapLocation.make_f (fun a -> `Constant (`Int a)) : loc:_ -> _ -> expression) + let constatn = (WrapLocation.make_f (fun a -> `Constant a) : loc:_ -> _ -> expression) + + let variable = (WrapLocation.make_f (fun a -> `Variable a) : loc:_ -> _ -> expression) + + let pair = (WrapLocation.make_f (fun a -> `Pair a) : loc:_ -> _ -> expression) + let application = (WrapLocation.make_f (fun a -> `Application a) : loc:_ -> _ -> expression) + + let let_ = (WrapLocation.make_f (fun a -> `Let a) : loc:_ -> _ -> assignment) + let type_ = (WrapLocation.make_f (fun a -> `Type a) : loc:_ -> _ -> assignment) + let fun_ = (WrapLocation.make_f (fun a -> `Function a) : loc:_ -> _ -> assignment) + let assignment = (WrapLocation.make_f (fun a -> `Assignment a) : loc:_ -> _ -> statement) + + let foreach = (WrapLocation.make_f (fun a -> `ForEach a) : loc:_ -> _ -> statement) + let while_ = (WrapLocation.make_f (fun a -> `While a) : loc:_ -> _ -> statement) + + let elseif x : (expression * block) = x + let else_ x : block = x + let if_ = (WrapLocation.make_f (fun a -> `Condition a) : loc:_ -> _ -> statement) + + let block = (WrapLocation.make : loc:_ -> _ -> block) + let program = (WrapLocation.make : loc:_ -> _ -> program) + end +end + +module Typed = struct + + module Type = struct + module WrapLocation = Wrap.Location + let wrap = WrapLocation.make + + type name = string + + type base = [ + | `Unit + | `Bool + | `Int + | `Nat + ] + + let unit : base = `Unit + let bool : base = `Bool + let int : base = `Int + let nat : base = `Nat + + type 'a node = [ + | `Pair of 'a * 'a + | `Or of 'a * 'a + ] + + type value = [ + | value node + | base + ] + + type expression_ast = [ + | expression node + | base + | `Name of name + ] + + and expression = expression_ast + + let rec of_untyped (x:Untyped.Type.expression) : expression = match x.value with + | `Pair(a, b) -> `Pair(of_untyped a, of_untyped b) + | `Or(a, b) -> `Or(of_untyped a, of_untyped b) + | `Int as s -> s + | `Unit as s -> s + | `Nat as s -> s + | `Bool as s -> s + | `Name _ as s -> s + + let pair_v a b : value = `Pair(a,b) + let union_v a b : value = `Or(a,b) + + let pair_e a b : expression = `Pair(a,b) + let union_e a b : expression = `Or(a,b) + + let name : string -> expression = function + | "Unit" -> (unit :> expression_ast) + | "Bool" -> (bool :> expression_ast) + | "Int" -> (int :> expression_ast) + | "Nat" -> (nat :> expression_ast) + | s -> `Name s + + module Environment = Environment.Make(val ( + Environment.parameter () : + (module Environment.PARAMETER + with type key = name + and type value = value))) + + let rec eval (env:Environment.t) : expression -> value result = function + | `Name x -> ( + trace_option (simple_error "name doesn't exist in environment") @@ + Environment.get_opt env x + ) + | `Pair (a, b) -> ( + eval env a >>? fun a -> + eval env b >>? fun b -> + ok (`Pair (a, b)) + ) + | `Or (a, b) -> ( + eval env a >>? fun a -> + eval env b >>? fun b -> + ok (`Or (a, b)) + ) + | `Bool as x -> ok x + | `Unit as x -> ok x + | `Nat as x -> ok x + | `Int as x -> ok x + end + + module Value = struct + module WrapLocation = Wrap.Location + let wrap = WrapLocation.make + module WrapTypeLocation = Wrap.Make(struct type meta = (Type.value * Location.t) end) + let wrap_tl = WrapTypeLocation.make + let type_of (x:'a WrapTypeLocation.t) : Type.value = fst x.meta + + type name = string + type function_name = string + + type constant = [ + | `Int of int + ] + + type 'a node = [ + | `Constant of constant + | `Pair of 'a * 'a + ] + let int n = `Constant (`Int n) + + type value = value node + type expression = [ + | expression node + | `Variable of name + ] WrapTypeLocation.t + + let variable n = `Variable n + let pair a b = `Pair (a, b) + + type assignment = [ + | `Let of name * expression + | `Type of Type.name * Type.value + | `Function of function_name * Type.value * block * Type.value + ] WrapLocation.t + + and statement = assignment + + and block = statement list + + and toplevel_statement = assignment + + and program = toplevel_statement list + + module Environment = Environment.Make(val ( + Environment.parameter () : + (module Environment.PARAMETER + with type key = name + and type value = Type.value))) + end + + module Environment = struct + type type_environment = Type.Environment.t + type value_environment = Value.Environment.t + + type t = { + type_environment : type_environment ; + value_environment : value_environment ; + } + + let empty = { + type_environment = Type.Environment.empty ; + value_environment = Value.Environment.empty ; + } + + let add_type env + name type_value = + { env with + type_environment = + Type.Environment.set env.type_environment name type_value } + + let add_variable env + name type_value = + { env with + value_environment = + Value.Environment.set env.value_environment name type_value } + end + +end + + +module Typecheck = struct + module UV = Untyped.Value + module UT = Untyped.Type + module TV = Typed.Value + module TT = Typed.Type + + type env = Typed.Environment.t + type ty = Typed.Type.value + + let typecheck_constant (constant:UV.constant) : _ = match constant with + | `Int n -> (`Int, `Int n) + + let rec typecheck_expression (env:env) (e:UV.expression) : (TV.expression) result = + match e.value with + | `Constant c -> ( + let (ty, value) = typecheck_constant c in + ok (TV.wrap_tl (ty, e.meta) (`Constant value)) + ) + | `Variable n -> ( + trace_option (simple_error "variable doesn't exist in env") + @@ TV.Environment.get_opt env.value_environment n >>? fun ty -> + ok (TV.wrap_tl (ty, e.meta) (TV.variable n)) + ) + | `Pair(a, b) -> ( + typecheck_expression env a >>? fun a -> + typecheck_expression env b >>? fun b -> + let ty = TT.pair_v (TV.type_of a) (TV.type_of b) in + ok (TV.wrap_tl (ty, e.meta) (TV.pair a b)) + ) + | `Application _ -> simple_fail "Application isn't supported yet" + + let rec typecheck_assignment (env:env) (u:UV.assignment) : (env * TV.assignment) result = + match u.value with + | `Let(name, expression) -> ( + typecheck_expression env expression >>? fun expression -> + let ass : TV.assignment = TV.wrap ~loc:u.meta (`Let(name, expression)) in + let env = Typed.Environment.add_variable env name (TV.type_of expression) in + ok (env, ass) + ) + | `Type(name, expression) -> ( + TT.eval env.type_environment (TT.of_untyped expression) >>? fun value -> + let env = Typed.Environment.add_type env name value in + let ass : TV.assignment = TV.wrap ~loc:u.meta (`Type(name, value)) in + ok (env, ass) + ) + | `Function(name, type_expression, block) -> ( + TT.eval env.type_environment (TT.of_untyped type_expression) >>? fun type_value -> + let env = Typed.Environment.add_variable env "input" type_value in + typecheck_block env block >>? fun (env, block) -> + let ty = + match TV.Environment.get_opt env.value_environment "output" with + | None -> `Unit + | Some x -> x in + let ass : TV.assignment = TV.wrap ~loc:u.meta (`Function(name, type_value, block, ty)) in + ok (env, ass) + ) + + and typecheck_statement (env:env) (s:Untyped.Value.statement) : (env * Typed.Value.statement) result = + match s.value with + | `Assignment a -> typecheck_assignment env a + | `Condition (_bool_expr, _block, _elseifs, _else_opt) -> simple_fail "conditions aren't supported yet" + | `ForEach _ -> simple_fail "foreach is not supported yet" + | `While _ -> simple_fail "while is not supported yet" + + and typecheck_block (env:env) (b:Untyped.Value.block) : (env * Typed.Value.block) result = + let rec aux env = function + | [] -> ok (env, []) + | hd :: tl -> ( + typecheck_statement env hd >>? fun (env, hd) -> + aux env tl >>? fun (env, tl) -> + ok (env, hd :: tl) + ) in + aux env b.value + + let typecheck_program ?(env=Typed.Environment.empty) (u:Untyped.Value.program) : Typed.Value.program result = + let rec aux env = function + | [] -> ok [] + | hd :: tl -> ( + typecheck_assignment env hd >>? fun (env, hd) -> + aux env tl >>? fun tl -> + ok (hd :: tl) + ) in + aux env u.value +end + +module Transpile = struct + open Mini_c + open Typed + + let rec translate_type : Type.value -> Mini_c.type_value result = function + | `Bool -> ok (`Base Bool) + | `Int -> ok (`Base Int) + | `Nat -> ok (`Base Nat) + | `Unit -> ok (`Base Unit) + | `Pair(a, b) -> ( + translate_type a >>? fun a -> + translate_type b >>? fun b -> + ok (`Pair(a, b)) + ) + | `Or(a, b) -> ( + translate_type a >>? fun a -> + translate_type b >>? fun b -> + ok (`Or(a, b)) + ) + + let rec translate_expression (e:Value.expression) : Mini_c.expression result = + let%bind (e' : Mini_c.expression') = match e.value with + | `Constant (`Int n) -> ok (Literal (`Int n)) + | `Variable n -> ok (Var n) + | `Pair (a, b) -> ( + translate_expression a >>? fun a -> + translate_expression b >>? fun b -> + ok (Predicate("Pair", [a ; b])) + ) in + let%bind (t : Mini_c.type_value) = translate_type @@ fst e.meta in + ok (e', t) + + let rec translate_assignment (ass:Value.assignment) + : Mini_c.assignment option result = match ass.value with + | `Let(x, expr) -> ( + translate_expression expr >>? fun expr -> + ok (Some (Variable(x, expr))) + ) + | `Function(name, input_ty, body, output_ty) -> ( + translate_type input_ty >>? fun input -> + translate_type output_ty >>? fun output -> + block body >>? fun body -> + let ass = Fun(name, {input ; output ; body}) in + ok (Some ass) + ) + | `Type _ -> ok None + + and statement (st:Value.statement) + : Mini_c.statement option result = + translate_assignment st >>? fun a -> + let ass = match a with + | Some a -> Some (Assignment a) + | None -> None in + ok ass + + and block : Value.block -> Mini_c.block result = function + | [] -> ok [] + | hd :: tl -> ( + statement hd >>? fun st_opt -> + let sts = match st_opt with + | Some x -> [x] + | None -> [] in + block tl >>? fun (new_sts) -> + ok (sts @ new_sts) + ) + + let translate_toplevel_statement = translate_assignment + + let rec program : Value.program -> Mini_c.program result = function + | [] -> ok [] + | hd :: tl -> ( + translate_assignment hd >>? fun ass_opt -> + let asss = match ass_opt with + | Some x -> [x] + | None -> [] in + program tl >>? fun (new_asss) -> + ok (asss @ new_asss) + ) + + let of_mini_c : Mini_c.value -> Value.value result = function + | `Int n -> ok (Value.int n) + | _ -> simple_fail "unknown value" + + let to_mini_c : Value.value -> Mini_c.value result = function + | `Constant (`Int n) -> ok (`Int n) + | _ -> simple_fail "unknown value" + + let program_to_michelson (p:Value.program) = + let%bind program_mini_c = program p in + let%bind program = Mini_c.Translate_program.translate program_mini_c in + ok program.body +end + +module Run = struct + open Typed.Value + let run (program : program) (input : value) : value result = + Transpile.program program >>? fun program_mini_c -> + Transpile.to_mini_c input >>? fun input_mini_c -> + (* Format.printf "%a\n" Mini_c.PP.program program_mini_c ; *) + Mini_c.Run.run program_mini_c input_mini_c >>? fun output_mini_c -> + Transpile.of_mini_c output_mini_c >>? fun output -> + ok output +end diff --git a/src/ligo/mini_c.ml b/src/ligo/mini_c.ml new file mode 100644 index 000000000..68c9079cf --- /dev/null +++ b/src/ligo/mini_c.ml @@ -0,0 +1,1079 @@ +open Ligo_helpers +open! Trace +open Tezos_utils.Memory_proto_alpha + +open Script_typed_ir +open Script_ir_translator + +module Michelson = Tezos_utils.Micheline.Michelson +module Stack = Meta_michelson.Wrap.Stack +module Types = Meta_michelson.Contract.Types + +type type_name = string + +type type_base = + | Unit + | Bool + | Int | Nat | Float + | String | Bytes + +type type_value = [ + | `Pair of type_value * type_value + | `Or of type_value * type_value + | `Function of type_value * type_value + | `Closure of environment_small * type_value * type_value + | `Base of type_base +] + +and environment_element = string * type_value + +and environment_small' = + | Leaf of environment_element + | Node of { + a : environment_small' ; + b : environment_small' ; + size : int ; + full : bool ; + } + +and environment_small = Empty | Full of environment_small' + +and environment = environment_small list + +type var_name = string +type fun_name = string + +let get_new_name = + let id = ref 0 in + fun str -> ( + id := !id + 1; + "_" ^ str ^ "_" ^ (string_of_int !id) + ) + +type value = [ + | `Unit + | `Bool of bool + | `Nat of int + | `Int of int + | `String of string + | `Pair of value * value + | `Left of value + | `Right of value + | `Function of anon_function (* Actually a macro *) + | `Closure of anon_closure +] + +and expression' = + | Literal of value + | Predicate of string * expression list + | Apply of expression * expression + | Var of var_name + +and expression = expression' * type_value + +and assignment = + | Fun of fun_name * anon_function + | Variable of var_name * expression + +and statement = + | Assignment of assignment + | Cond of expression * block * block + | While of expression * block + +and anon_function = { + input : type_value ; + output : type_value ; + body : block ; +} + +and anon_closure = { + capture : value ; + anon_function : anon_function ; +} + +and block = statement list + +and toplevel_statement = assignment + +and program = toplevel_statement list + +module PP = struct + open Format + + let space_sep ppf () = fprintf ppf " " + + let type_base ppf : type_base -> _ = function + | Unit -> fprintf ppf "unit" + | Bool -> fprintf ppf "bool" + | Int -> fprintf ppf "int" + | Float -> fprintf ppf "float" + | Nat -> fprintf ppf "nat" + | String -> fprintf ppf "string" + | Bytes -> fprintf ppf "bytes" + + let rec type_ ppf : type_value -> _ = function + | `Or(a, b) -> fprintf ppf "(%a) | (%a)" type_ a type_ b + | `Pair(a, b) -> fprintf ppf "(%a) & (%a)" type_ a type_ b + | `Base b -> type_base ppf b + | `Function(a, b) -> fprintf ppf "(%a) -> (%a)" type_ a type_ b + | `Closure(c, arg, ret) -> + fprintf ppf "[%a](%a)->(%a)" + environment_small c + type_ arg type_ ret + + and environment_element ppf ((s, tv) : environment_element) = + Format.fprintf ppf "%s : %a" s type_ tv + + and environment_small' ppf = function + | Leaf x -> environment_element ppf x + | Node {a; b ; full ; size} -> + fprintf ppf "@[N(f:%b,s:%d)[@;%a,@;%a@]@;]" + full size + environment_small' a environment_small' b + + and environment_small ppf = function + | Empty -> fprintf ppf "[]" + | Full x -> environment_small' ppf x + + and environment_small_hlist' ppf = function + | Leaf x -> environment_element ppf x + | Node {a;b} -> + fprintf ppf "%a, %a" + environment_small_hlist' a + environment_small_hlist' b + + and environment_small_hlist ppf = function + | Empty -> fprintf ppf "" + | Full x -> environment_small_hlist' ppf x + + let environment ppf (x:environment) = Format.pp_print_list environment_small ppf x + + let rec value ppf : value -> _ = function + | `Bool b -> fprintf ppf "%b" b + | `Int n -> fprintf ppf "%d" n + | `Nat n -> fprintf ppf "%d" n + | `Unit -> fprintf ppf " " + | `String s -> fprintf ppf "\"%s\"" s + | `Pair (a, b) -> fprintf ppf "(%a), (%a)" value a value b + | `Left a -> fprintf ppf "L(%a)" value a + | `Right b -> fprintf ppf "R(%a)" value b + | `Function x -> function_ ppf x + | `Closure {capture;anon_function} -> + fprintf ppf "[%a]%a" + value capture + function_ anon_function + + and expression ppf ((e, _):expression) = match e with + | Var v -> fprintf ppf "%s" v + | Apply(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b + | Predicate(p, lst) -> fprintf ppf "%s %a" p (pp_print_list ~pp_sep:space_sep expression) lst + | Literal v -> fprintf ppf "%a" value v + + and function_ ppf ({input ; output ; body}:anon_function) = + fprintf ppf "fun (%a) : %a %a" + type_ input + type_ output + block body + + and assignment ppf (ass:assignment) = + match ass with + | Variable (n, e) -> fprintf ppf "let %s = %a;" n expression e + | Fun (n, f) -> fprintf ppf "let %s = %a" n function_ f + + and statement ppf : statement -> _ = function + | Assignment ass -> assignment ppf ass + | Cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e + | While (e, b) -> fprintf ppf "while (%a) %a" expression e block b + + and block ppf (block:block) = + fprintf ppf "@[{@,%a@]@,}" (pp_print_list ~pp_sep:pp_print_newline statement) block + + let tl_statement = assignment + + let program ppf (p:program) = + fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p +end + +module Free_variables = struct + type free_variable = string + type free_variables = free_variable list + type t' = free_variable + type t = free_variables + + let append_wd (* without doubles *) double x t = + if List.mem x double + then t + else x :: t + + let append_bound x t = append_wd t x t + + let rec expression' (bound:t) : expression' -> t = function + | Literal _ -> [] + | Var x -> append_wd bound x [] + | Predicate(_, exprs) -> List.(concat @@ map (expression bound) exprs) + | Apply(a, b) -> List.(concat @@ map (expression bound) [a;b]) + + and expression bound expr = expression' bound (fst expr) + + let rec statement bound : statement -> (t * t) = function + | Assignment (Variable (n, e)) -> append_bound n bound, expression bound e + | Assignment (Fun (n, f)) -> append_bound n bound, block (append_bound "input" @@ append_bound "output" bound) f.body + | Cond (e, a, b) -> bound, (expression bound e) @ (block bound a) @ (block bound b) + | While (e, b) -> bound, (expression bound e) @ (block bound b) + + and block bound : block -> t = function + | [] -> [] + | hd :: tl -> + let (bound, fv) = statement bound hd in + let fv' = block bound tl in + fv @ fv' + + let function_ ({body} : anon_function) : t = + block ["input" ; "output"] body +end + +module Translate_type = struct + open Tezos_utils.Micheline.Michelson + + module Ty = struct + + let base_type : type_base -> ex_ty result = + function + | Unit -> ok @@ Ex_ty Types.unit + | Bool -> ok @@ Ex_ty Types.bool + | Int -> ok @@ Ex_ty Types.int + | _ -> simple_fail "all based types not supported yet" + + let rec type_ : type_value -> ex_ty result = + function + | `Base b -> base_type b + | `Pair (t, t') -> ( + type_ t >>? fun (Ex_ty t) -> + type_ t' >>? fun (Ex_ty t') -> + ok @@ Ex_ty (Types.pair t t') + ) + | `Or (t, t') -> ( + type_ t >>? fun (Ex_ty t) -> + type_ t' >>? fun (Ex_ty t') -> + ok @@ Ex_ty (Types.union t t') + ) + | `Function (arg, ret) -> + let%bind (Ex_ty arg) = type_ arg in + let%bind (Ex_ty ret) = type_ ret in + ok @@ Ex_ty (Types.lambda arg ret) + | `Closure (c, arg, ret) -> + let%bind (Ex_ty capture) = environment_small c in + let%bind (Ex_ty arg) = type_ arg in + let%bind (Ex_ty ret) = type_ ret in + ok @@ Ex_ty Types.(pair capture @@ lambda (pair capture arg) ret) + + and environment_small' = function + | Leaf (_, x) -> type_ x + | Node {a;b} -> + let%bind (Ex_ty a) = environment_small' a in + let%bind (Ex_ty b) = environment_small' b in + ok @@ Ex_ty (Types.pair a b) + + and environment_small = function + | Empty -> ok @@ Ex_ty Types.unit + | Full x -> environment_small' x + + let rec environment = function + | [] -> simple_fail "Schema.Big.to_ty" + | [a] -> environment_small a + | a::b -> + let%bind (Ex_ty a) = environment_small a in + let%bind (Ex_ty b) = environment b in + ok @@ Ex_ty (Types.pair a b) + end + + + let base_type : type_base -> michelson result = + function + | Unit -> ok @@ prim T_unit + | Bool -> ok @@ prim T_bool + | Int -> ok @@ prim T_int + | _ -> simple_fail "all based types not supported yet" + + let rec type_ : type_value -> michelson result = + function + | `Base b -> base_type b + | `Pair (t, t') -> ( + type_ t >>? fun t -> + type_ t' >>? fun t' -> + ok @@ prim ~children:[t;t'] T_pair + ) + | `Or (t, t') -> ( + type_ t >>? fun t -> + type_ t' >>? fun t' -> + ok @@ prim ~children:[t;t'] T_or + ) + | `Function (arg, ret) -> + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ prim ~children:[arg;ret] T_lambda + | `Closure (c, arg, ret) -> + let%bind capture = environment_small c in + let%bind arg = type_ arg in + let%bind ret = type_ ret in + ok @@ t_pair capture (t_lambda (t_pair capture arg) ret) + + and environment_element (name, tyv) = + let%bind michelson_type = type_ tyv in + ok @@ annotate ("@" ^ name) michelson_type + + and environment_small' = function + | Leaf x -> environment_element x + | Node {a;b} -> + let%bind a = environment_small' a in + let%bind b = environment_small' b in + ok @@ t_pair a b + + and environment_small = function + | Empty -> ok @@ prim T_unit + | Full x -> environment_small' x + + let rec environment = + function + | [] -> simple_fail "Schema.Big.to_michelson_type" + | [a] -> environment_small a + | a :: b -> + let%bind a = environment_small a in + let%bind b = environment b in + ok @@ t_pair a b + +end + +module Math = struct + + let lt_power_of_two n = + let rec aux prev n = + let cur = prev * 2 in + if cur >= n + then prev + else aux cur n + in + if n > 0 + then ok (aux 1 n) + else fail @@ error "lt_power_of_two" (string_of_int n) + + let ge_power_of_two n = + let rec aux c n = + if c >= n + then c + else aux (c * 2) n + in + if n > 0 + then ok (aux 1 n) + else fail @@ error "ge_power_of_two" (string_of_int n) + + let rec exp x n = + if n = 0 + then 1 + else + let exp' = exp (x * x) (n / 2) in + let m = if n mod 2 = 0 then 1 else x in + m * exp' + + let exp2 = exp 2 + + let log2_c n = + let rec aux acc n = + if n = 1 + then acc + else aux (acc + 1) (n / 2) + in + if n < 1 then raise @@ Failure ("log_2") ; + let n' = aux 0 n in + if exp2 n' = n then n' else n' + 1 + + let int_to_bools n l = + let rec aux acc n = function + | 0 -> acc + | s -> aux ((n mod 2 = 0) :: acc) (n / 2) (s - 1) + in + List.rev @@ aux [] n l + +end + + +module Environment = struct + open Tezos_utils.Micheline + + type element = environment_element + + module Small = struct + type t' = environment_small' + type t = environment_small + + let node (a, b, size, full) = Node {a;b;size;full} + + let rec has' s = function + | Leaf (s',_) when s = s' -> true + | Leaf _ -> false + | Node{a;b} -> has' s a || has' s b + let has s = function + | Empty -> false + | Full x -> has' s x + + let empty : t = Empty + + let size' = function + | Leaf _ -> 1 + | Node {size} -> size + + let size = function + | Empty -> 0 + | Full x -> size' x + + let rec append' x = function + | Leaf e -> node (Leaf e, Leaf x, 1, true) + | Node({full=true;size}) as n -> node(n, Leaf x, size + 1, false) + | Node({a=Node a;b;full=false} as n) -> ( + match append' x b with + | Node{full=false} as b -> Node{n with b} + | Node({full=true} as b) -> Node{n with b = Node b ; full = b.size = a.size} + | Leaf _ -> assert false + ) + | Node{a=Leaf _;full=false} -> assert false + + let append ((s, _) as x) = function + | Empty -> Full (Leaf x) + | Full t -> + if has' s t then Full (t) else Full (append' x t) + + let of_list lst = + let rec aux = function + | [] -> Empty + | hd :: tl -> append hd (aux tl) + in + aux @@ List.rev lst + + type bound = string list + + let rec env_of_expression bound prev ((e, tv) : expression) : t = match e with + | Var n -> if List.mem n bound then prev else append (n, tv) prev + | Literal _ -> prev + | Apply (a, b) -> + let prev = env_of_expression bound prev a in + let prev = env_of_expression bound prev b in + prev + | Predicate (_, exprs) -> + List.fold_left (env_of_expression bound) prev exprs + + let rec env_of_statement bound prev : statement -> (bound * t) = function + | Assignment (Variable (n, expr)) -> + let bound = n :: bound in + bound, env_of_expression bound prev expr + | Assignment (Fun (n, {body})) -> + let bound = n :: bound in + bound, env_of_block bound prev body + | Cond (expr, ba, bb) -> + let prev = env_of_expression bound prev expr in + let prev = env_of_block bound prev ba in + let prev = env_of_block bound prev bb in + (bound, prev) + | While (expr, b) -> + let prev = env_of_expression bound prev expr in + let prev = env_of_block bound prev b in + (bound, prev) + + and env_of_block (bound:string list) prev : block -> t = function + | [] -> prev + | hd :: tl -> + let (bound, prev) = env_of_statement bound prev hd in + env_of_block bound prev tl + + let env_of_anon ({body} : anon_function) : t = + let init = empty in + env_of_block ["input"] init body + + let init_function input : t = + append ("input", input) @@ + empty + + open Michelson + + let rec to_michelson_get' s = function + | Leaf (n, tv) when n = s -> ok @@ (seq [], tv) + | Leaf _ -> simple_fail "Schema.Small.get : not in env" + | Node {a;b} -> ( + match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_get' s) (a, b) with + | `Left (x, tv) -> ok @@ (seq [i_car ; x], tv) + | `Right (x, tv) -> ok @@ (seq [i_cdr ; x], tv) + ) + let to_michelson_get s = function + | Empty -> simple_fail "Schema.Small.get : not in env" + | Full x -> to_michelson_get' s x + + let rec to_michelson_set' s = function + | Leaf (n, tv) when n = s -> ok (dip i_drop, tv) + | Leaf _ -> simple_fail "Schema.Small.set : not in env" + | Node {a;b} -> ( + match%bind bind_lr @@ Tezos_utils.Tuple.map2 (to_michelson_set' s) (a, b) with + | `Left (x, tv) -> ok (seq [dip i_unpair ; x ; i_pair], tv) + | `Right (x, tv) -> ok (seq [dip i_unpiar ; x ; i_piar], tv) + ) + let to_michelson_set s = function + | Empty -> simple_fail "Schema.Small.set : not in env" + | Full x -> to_michelson_set' s x + + let rec to_michelson_append' = function + | Leaf _ -> ok i_piar + | Node{full=true} -> ok i_piar + | Node{a=Node _;b;full=false} -> + let%bind b = to_michelson_append' b in + ok @@ seq [dip i_unpiar ; b ; i_piar] + | Node{a=Leaf _;full=false} -> assert false + + let to_michelson_append = function + | Empty -> ok (dip i_drop) + | Full x -> to_michelson_append' x + + let rec to_mini_c_capture' = function + | Leaf (n, tv) -> ok (Var n, tv) + | Node {a;b} -> + let%bind ((_, ty_a) as a) = to_mini_c_capture' a in + let%bind ((_, ty_b) as b) = to_mini_c_capture' b in + ok (Predicate ("PAIR", [a;b]), `Pair(ty_a, ty_b)) + + let to_mini_c_capture = function + | Empty -> simple_fail "sub env fail" + | Full x -> to_mini_c_capture' x + + let rec to_mini_c_type' = function + | Leaf (_, t) -> t + | Node {a;b} -> `Pair(to_mini_c_type' a, to_mini_c_type' b) + + let to_mini_c_type = function + | Empty -> `Base Unit + | Full x -> to_mini_c_type' x + end + + type t = environment + + let empty : t = [Small.empty] + let extend t : t = Small.empty :: t + let restrict t : t = List.tl t + let of_small small : t = [small] + + let has x : t -> bool = function + | [] -> raise (Failure "Schema.Big.has") + | hd :: _ -> Small.has x hd + let add x : t -> t = function + | [] -> raise (Failure "Schema.Big.add") + | hd :: tl -> Small.append x hd :: tl + + let init_function f : t = [Small.init_function f] + + let to_michelson_extend = Michelson.( + seq [i_push_unit ; i_pair] + ) + let to_michelson_restrict = Michelson.i_cdr + + let to_ty = Translate_type.Ty.environment + let to_michelson_type = Translate_type.environment + let rec to_mini_c_type = function + | [] -> raise (Failure "Schema.Big.to_mini_c_type") + | [hd] -> Small.to_mini_c_type hd + | hd :: tl -> `Pair(Small.to_mini_c_type hd, to_mini_c_type tl) + let to_mini_c_capture = function + | [a] -> Small.to_mini_c_capture a + | _ -> raise (Failure "Schema.Big.to_mini_c_capture") + + let to_michelson_add x (t:t) = + let%bind code = match t with + | [] -> simple_fail "Schema.Big.Add.to_michelson_add" + | [hd] -> Small.to_michelson_append hd + | hd :: _ -> ( + let%bind code = Small.to_michelson_append hd in + ok @@ Michelson.(seq [dip i_unpair ; code ; i_pair]) + ) + in + + let%bind _assert_type = + let new_schema = add x t in + let%bind (Ex_ty schema_ty) = to_ty t in + let%bind (Ex_ty new_schema_ty) = to_ty new_schema in + let%bind (Ex_ty input_ty) = Translate_type.Ty.type_ (snd x) in + let input_stack_ty = Stack.(input_ty @: schema_ty @: nil) in + let output_stack_ty = Stack.(new_schema_ty @: nil) in + let error_message = Format.asprintf + "\nold : %a\nnew : %a\ncode : %a\n" + PP.environment t + PP.environment new_schema + Tezos_utils.Micheline.Michelson.pp code in + let%bind _ = + trace_tzresult_lwt (error "error parsing Schema.Big.to_michelson_add code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty in + ok () + in + + ok code + + let to_michelson_get (s:t) str : (Michelson.t * type_value) result = + let open Michelson in + let rec aux s str : (Michelson.t * type_value) result = match s with + | [] -> simple_fail "Schema.Big.get" + | [a] -> Small.to_michelson_get str a + | a :: b -> ( + match Small.to_michelson_get str a with + | Ok (code, tv) -> ok (seq [i_car ; code], tv) + | Errors _ -> + let%bind (code, tv) = aux b str in + ok (seq [i_car ; code], tv) + ) + in + let%bind (code, tv) = aux s str in + + let%bind _assert_type = + let%bind (Ex_ty schema_ty) = to_ty s in + let%bind schema_michelson = to_michelson_type s in + let%bind (Ex_ty ty) = Translate_type.Ty.type_ tv in + let input_stack_ty = Stack.(schema_ty @: nil) in + let output_stack_ty = Stack.(ty @: nil) in + let%bind error_message = + ok @@ Format.asprintf + "\ncode : %a\nschema type : %a" + Tezos_utils.Micheline.Michelson.pp code + Tezos_utils.Micheline.Michelson.pp schema_michelson + in + let%bind _ = + Trace.trace_tzresult_lwt (error "error parsing big.get code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + + ok (code, tv) + + let to_michelson_set str (s:t) : Michelson.t result = + let open Michelson in + let rec aux s str : (Michelson.t * type_value) result = + match s with + | [] -> simple_fail "Schema.Big.get" + | [a] -> Small.to_michelson_set str a + | a :: b -> ( + match Small.to_michelson_set str a with + | Ok (code, tv) -> ok (seq [dip i_unpair ; code ; i_pair], tv) + | Errors _ -> aux b str + ) + in + let%bind (code, tv) = aux s str in + + let%bind _assert_type = + let%bind (Ex_ty schema_ty) = to_ty s in + let%bind schema_michelson = to_michelson_type s in + let%bind (Ex_ty ty) = Translate_type.Ty.type_ tv in + let input_stack_ty = Stack.(ty @: schema_ty @: nil) in + let output_stack_ty = Stack.(schema_ty @: nil) in + let%bind error_message = + ok @@ Format.asprintf + "\ncode : %a\nschema type : %a" + Tezos_utils.Micheline.Michelson.pp code + Tezos_utils.Micheline.Michelson.pp schema_michelson + in + let%bind _ = + Trace.trace_tzresult_lwt (error "error parsing big.get code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + + ok code +end + +module Translate_program = struct + open Tezos_utils.Micheline.Michelson + + type predicate = + | Constant of michelson + | Unary of michelson + | Binary of michelson + | Ternary of michelson + + let simple_unary c = Unary ( seq [ + i_unpair ; c ; i_pair ; + ]) + + let simple_binary c = Binary ( seq [ + i_unpair ; dip i_unpair ; c ; i_pair ; + ]) + + let rec get_predicate : string -> predicate result = function + | "ADD_INT" -> ok @@ simple_binary @@ prim I_ADD + | "NEG" -> ok @@ simple_unary @@ prim I_NEG + | "PAIR" -> ok @@ simple_binary @@ prim I_PAIR + | x -> simple_fail @@ "predicate \"" ^ x ^ "\" doesn't exist" + + and translate_value s (v:value) : michelson result = match v with + | `Bool b -> ok @@ prim (if b then D_True else D_False) + | `Int n -> ok @@ int (Z.of_int n) + | `Nat n -> ok @@ int (Z.of_int n) + | `String s -> ok @@ string s + | `Unit -> ok @@ prim D_Unit + | `Pair (a, b) -> ( + let%bind a = translate_value s a in + let%bind b = translate_value s b in + ok @@ prim ~children:[a;b] D_Pair + ) + | `Left a -> translate_value s a >>? fun a -> ok @@ prim ~children:[a] D_Left + | `Right b -> translate_value s b >>? fun b -> ok @@ prim ~children:[b] D_Right + | `Function _ -> simple_fail "translating value : function" + | `Closure _ -> simple_fail "translating value : closure" + + and translate_expression (s:Environment.t) ((e, ty):expression) : michelson result = + let error_message = Format.asprintf "%a" PP.expression (e, ty) in + let%bind (code : michelson) = trace (error "translating expression" error_message) @@ match e with + | Literal v -> + let%bind v = translate_value s v in + let%bind t = Translate_type.type_ ty in + ok @@ seq [ + prim ~children:[t;v] I_PUSH ; + prim I_PAIR ; + ] + | Apply(f, arg) -> ( + match snd f with + | `Function _ -> ( + let%bind f = translate_expression s f in + let%bind arg = translate_expression s arg in + ok @@ seq [ + arg ; + i_unpair ; + dip f ; + dip i_unpair ; + prim I_EXEC ; + i_pair ; + ] + ) + | `Closure _ -> ( + let%bind f = translate_expression s f in + let%bind arg = translate_expression s arg in + ok @@ seq [ + arg ; + i_unpair ; + dip f ; + dip i_unpair ; + dip i_unpair ; + i_piar ; + prim I_EXEC ; + i_pair ; + ] + ) + | _ -> simple_fail "Applying something not appliable" + ) + | Var x -> + let%bind (get, _) = Environment.to_michelson_get s x in + ok @@ seq [ + dip (seq [prim I_DUP ; get]) ; + i_piar ; + ] + | Predicate(str, lst) -> + let%bind lst = bind_list @@ List.map (translate_expression s) lst in + let%bind predicate = get_predicate str in + let%bind code = match (predicate, List.length lst) with + | Constant c, 0 -> ok (seq @@ lst @ [c]) + | Unary f, 1 -> ok (seq @@ lst @ [f]) + | Binary f, 2 -> ok (seq @@ lst @ [f]) + | Ternary f, 3 -> ok (seq @@ lst @ [f]) + | _ -> simple_fail "bad arity" + in + ok code + in + + let%bind () = + let%bind (Ex_ty schema_ty) = Environment.to_ty s in + let%bind output_ty = Translate_type.type_ ty in + let%bind (Ex_ty output_ty) = + let error_message = Format.asprintf "%a" Michelson.pp output_ty in + Trace.trace_tzresult_lwt (error "error parsing output ty" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson_ty output_ty in + let input_stack_ty = Stack.(Types.unit @: schema_ty @: nil) in + let output_stack_ty = Stack.(Types.(pair output_ty unit) @: schema_ty @: nil) in + let%bind error_message = + let%bind schema_michelson = Environment.to_michelson_type s in + ok @@ Format.asprintf + "expression : %a\ncode : %a\nschema type : %a" + PP.expression (e, ty) + Tezos_utils.Micheline.Michelson.pp code + Tezos_utils.Micheline.Michelson.pp schema_michelson + in + let%bind _ = + Trace.trace_tzresult_lwt (error "error parsing expression code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + ok code + + and translate_statement schema (s:statement) : (michelson * Environment.t) result = + let error_message = Format.asprintf "%a" PP.statement s in + let%bind ((code, new_schema) : michelson * Environment.t) = + trace (error "translating statement" error_message) @@ match s with + | Assignment (Variable (s, ((_, tv) as expr))) -> + let%bind expr = translate_expression schema expr in + let new_schema = Environment.add (s, tv) schema in + let%bind add = + if Environment.has s schema + then Environment.to_michelson_set s schema + else Environment.to_michelson_add (s, tv) schema + in + ok (seq [ + i_comment "assignment" ; + seq [ + i_comment "expr" ; + i_push_unit ; expr ; i_car ; + ] ; + seq [ + i_comment "env <- env . expr" ; + add ; + ]; + ], new_schema) + | Assignment (Fun (s, anon)) -> ( + match Environment.Small.env_of_anon anon with + | Empty -> ( (* If there is no free variable, translate as a quote *) + let env = Environment.init_function anon.input in + let%bind body = translate_function_body env anon in + let%bind input = Translate_type.type_ anon.input in + let%bind output = Translate_type.type_ anon.output in + let tv = `Function(anon.input, anon.output) in + let new_schema = Environment.add (s, tv) schema in + let%bind set = Environment.to_michelson_add (s, tv) schema in + ok @@ (seq [ + i_lambda input output body ; + set ; + ], new_schema) + ) + | (Full _) as small_env -> ( (* If there are free variables, translate as a closure *) + let env = Environment.(of_small @@ Small.append ("input", anon.input) small_env) in + let input = Environment.to_mini_c_type env in + let%bind body = translate_function_body env ({anon with input}) in + let%bind capture = Environment.Small.to_mini_c_capture small_env in + let%bind capture = translate_expression schema capture in + let tv : type_value = `Closure(small_env, anon.input, anon.output) in + let%bind add = Environment.to_michelson_add (s, tv) schema in + let%bind input_type = Translate_type.type_ input in + let%bind output_type = Translate_type.type_ anon.output in + let code = seq [ + i_push_unit ; capture ; i_car ; + i_lambda input_type output_type body ; + i_piar ; + add ; + ] in + + let new_schema = Environment.add (s, tv) schema in + ok (code, new_schema) + ) + ) + | Cond (expr, a, b) -> + let new_schema = Environment.extend schema in + let%bind expr = translate_expression schema expr in + let%bind (a, _) = translate_regular_block new_schema a in + let%bind (b, _) = translate_regular_block new_schema b in + ok @@ (seq [ + prim ~children:[prim T_unit ; prim D_Unit] I_PUSH ; + expr ; + prim I_CAR ; + dip Environment.to_michelson_extend ; + prim ~children:[seq [a ; Environment.to_michelson_restrict];seq [b ; Environment.to_michelson_restrict]] I_IF ; + ], schema) + | While (expr, block) -> + let%bind expr = translate_expression schema expr in + let new_schema = Environment.extend schema in + let%bind (block, _) = translate_regular_block new_schema block in + ok @@ (seq [ + i_push_unit ; expr ; i_car ; + dip Environment.to_michelson_extend ; + prim ~children:[block ; Environment.to_michelson_restrict ; i_push_unit ; expr ; i_car] I_LOOP ; + ], schema) + in + + let%bind _assert_type = + let%bind (Ex_ty schema_ty) = Environment.to_ty schema in + let%bind (Ex_ty new_schema_ty) = Environment.to_ty new_schema in + let%bind schema_michelson = Environment.to_michelson_type schema in + let%bind new_schema_michelson = Environment.to_michelson_type new_schema in + let input_stack_ty = Stack.(schema_ty @: nil) in + let output_stack_ty = Stack.(new_schema_ty @: nil) in + let%bind error_message = + ok @@ Format.asprintf + "\nstatement : %a\ncode : %a\nschema type : %a\nnew schema type : %a" + PP.statement s + Tezos_utils.Micheline.Michelson.pp code + Tezos_utils.Micheline.Michelson.pp schema_michelson + Tezos_utils.Micheline.Michelson.pp new_schema_michelson + in + let%bind _ = + Trace.trace_tzresult_lwt (error "error parsing statement code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + + ok (code, new_schema) + + and translate_regular_block schema b : (michelson * Environment.t) result = + let aux prev statement = + let%bind ((lst, schema) : (michelson list * Environment.t)) = prev in + let%bind (instruction, new_schema) = translate_statement schema statement in + ok (instruction :: lst, new_schema) + in + let%bind error_message = + let%bind schema_michelson = Environment.to_michelson_type schema in + ok @@ Format.asprintf "\nblock : %a\nschema : %a\n" + PP.block b + Tezos_utils.Micheline.Michelson.pp schema_michelson + in + let%bind (codes, last_schema) = + trace (error "error translating block" error_message) @@ + List.fold_left aux (ok ([], schema)) b in + let code = seq (List.rev codes) in + ok (code, last_schema) + + and translate_function_body env ({body} as f:anon_function) : michelson result = + let schema = env in + let%bind (body, post_schema) = translate_regular_block schema body in + let%bind (get_output, _) = Environment.to_michelson_get post_schema "output" in + let code = seq [ + body ; + get_output ; + ] in + + let%bind _assert_type = + let%bind (Ex_ty input_ty) = Translate_type.Ty.type_ f.input in + let%bind (Ex_ty output_ty) = Translate_type.Ty.type_ f.output in + let input_stack_ty = Stack.(input_ty @: nil) in + let output_stack_ty = Stack.(output_ty @: nil) in + let%bind error_message = + ok @@ Format.asprintf + "\ncode : %a\n" + Tezos_utils.Micheline.Michelson.pp code + in + let%bind _ = + Trace.trace_tzresult_lwt (error "error parsing function code" error_message) @@ + Tezos_utils.Memory_proto_alpha.parse_michelson code + input_stack_ty output_stack_ty + in + ok () + in + + ok code + + type compiled_program = { + input : ex_ty ; + output : ex_ty ; + body : michelson ; + } + + let translate (p:program) : compiled_program result = + let is_main = function + | Fun ("main", f) -> Some f + | _ -> None in + let%bind main = + trace_option (simple_error "no main") @@ + Tezos_utils.List.find_map is_main p in + let {input;output} : anon_function = main in + let%bind body = translate_function_body (Environment.init_function input) main in + let%bind input = Translate_type.Ty.type_ input in + let%bind output = Translate_type.Ty.type_ output in + ok ({input;output;body}:compiled_program) + +end + +module Translate_ir = struct + + let rec translate_value (Ex_typed_value (ty, value)) : value result = + match (ty, value) with + | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> ( + let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + ok @@ `Pair(a, b) + ) + | Union_t ((a_ty, _), _, _), L a -> ( + let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + ok @@ `Left a + ) + | Union_t (_, (b_ty, _), _), R b -> ( + let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + ok @@ `Right b + ) + | (Int_t _), n -> + let%bind n = + trace_option (simple_error "too big to fit an int") @@ + Alpha_context.Script_int.to_int n in + ok @@ `Int n + | (Nat_t _), n -> + let%bind n = + trace_option (simple_error "too big to fit an int") @@ + Alpha_context.Script_int.to_int n in + ok @@ `Nat n + | _ -> simple_fail "this value can't be transpiled back yet" +end + +module Run = struct + + open Tezos_utils.Micheline + + let run_aux (program:program) (input_michelson:Michelson.t) : ex_typed_value result = + let open Meta_michelson.Wrap in + let%bind {input;output;body} = Translate_program.translate program in + let (Ex_ty input_ty) = input in + let (Ex_ty output_ty) = output in + let%bind input = + Trace.trace_tzresult_lwt (simple_error "error parsing input") @@ + Tezos_utils.Memory_proto_alpha.parse_michelson_data input_michelson input_ty in + let body = Michelson.strip_annots body in + let%bind descr = + Trace.trace_tzresult_lwt (simple_error "error parsing program code") @@ + Tezos_utils.Memory_proto_alpha.parse_michelson body + (Stack.(input_ty @: nil)) (Stack.(output_ty @: nil)) in + let open! Script_interpreter in + let%bind (Item(output, Empty)) = + Trace.trace_tzresult_lwt (simple_error "error of execution") @@ + Tezos_utils.Memory_proto_alpha.interpret descr (Item(input, Empty)) in + ok (Ex_typed_value (output_ty, output)) + + let run_node (program:program) (input:Michelson.t) : Michelson.t result = + let%bind (Ex_typed_value (output_ty, output)) = run_aux program input in + let%bind output = + Trace.trace_tzresult_lwt (simple_error "error unparsing output") @@ + Tezos_utils.Memory_proto_alpha.unparse_michelson_data output_ty output in + ok output + + let run (program:program) (input:value) : value result = + let%bind input_michelson = Translate_program.translate_value Environment.empty input in + let%bind ex_ty_value = run_aux program input_michelson in + let%bind (result : value) = Translate_ir.translate_value ex_ty_value in + ok result + +end + +module Combinators = struct + + let var x : expression' = Var x + let apply a b : expression' = Apply(a, b) + + let t_int : type_value = `Base Int + let type_int x : expression = x, `Base Int + let type_f_int x : expression = x,`Function (`Base Int, `Base Int) + let type_closure_int t x : expression = x, `Closure (t, `Base Int, `Base Int) + let int n = type_int @@ Literal(`Int n) + let neg_int x = type_int @@ Predicate("NEG", [x]) + let add_int x y = type_int @@ Predicate("ADD_INT", [x ; y]) + let var_int x = type_int @@ var x + let apply_int a b = type_int @@ apply a b + + let assign_variable v expr = Assignment (Variable (v, expr)) + let assign_function v anon = Assignment (Fun (v, anon)) + let function_int body = { + input = `Base Int ; + output = `Base Int ; + body ; + } + +end diff --git a/src/ligo/parser.mly b/src/ligo/parser.mly new file mode 100644 index 000000000..91c5bf36e --- /dev/null +++ b/src/ligo/parser.mly @@ -0,0 +1,200 @@ +%{ + module Location = Ligo_helpers.Location + open Main.Untyped + open Value +%} + +%token EOF +%token INT +//%token FLOAT +%token STRING +%token VAR_NAME +%token FUNCTION_NAME +%token TYPE_NAME +//%token PLUS MINUS TIMES DIV +%token COLON SEMICOLON /* DOUBLE_SEMICOLON */ COMMA AT EQUAL DOT +%token OR AND +%token LPAREN RPAREN +%token LBRACKET RBRACKET +%token IF ELSEIF ELSE // THEN +%token FOREACH OF WHILE +%token LET TYPE FUNCTION + + +// toto.tata @ 3 + 4 = 2 ; printf (lel) +//%left COLON +%left COMMA +%left AT +%left OR +%left AND +//%left EQUAL +//%left PLUS MINUS /* lowest precedence */ +//%left TIMES DIV /* medium precedence */ +%left DOT + +%start main + +%% + +main: + | sts = assignment+ EOF + { + let loc = Location.make $startpos $endpos in + program ~loc sts + } + +assignment: + | LET v = VAR_NAME EQUAL e = expr SEMICOLON + { + let loc = Location.make $startpos $endpos in + let_ ~loc (v, e) + } + | FUNCTION f = VAR_NAME COLON t = type_expr EQUAL b = block SEMICOLON + { + let loc = Location.make $startpos $endpos in + fun_ ~loc (f, t, b) + } + | TYPE n = TYPE_NAME EQUAL t = type_expr SEMICOLON + { + let loc = Location.make $startpos $endpos in + type_ ~loc (n, t) + } + +statement: + | ass = assignment + { + let loc = Location.make $startpos $endpos in + assignment ~loc ass + } + | FOREACH var = VAR_NAME OF iterator = expr body = block + { + let loc = Location.make $startpos $endpos in + foreach ~loc (var, iterator, body) + } + | WHILE cond = expr body = block + { + let loc = Location.make $startpos $endpos in + while_ ~loc (cond, body) + } + | IF e = expr b = block eis = else_if* eo = else_? + { + let loc = Location.make $startpos $endpos in + if_ ~loc (e, b, eis, eo) + } + +else_if: + | ELSEIF LPAREN cond = expr RPAREN body = block + { + elseif (cond, body) + } + +else_: + | ELSE body = block + { + else_ body + } + +block: + | LBRACKET sts = statement+ RBRACKET + { + let loc = Location.make $startpos $endpos in + block ~loc sts + } + +expr: + | i = INT + { + let loc = Location.make $startpos $endpos in + Value.int ~loc i + } +(* + | f = FLOAT + { + let loc = Location.make $startpos $endpos in + make ~loc @@ literal @@ Float f + } + | s = STRING + { + let loc = Location.make $startpos $endpos in + make ~loc @@ literal @@ String s + } +*) + | v = VAR_NAME + { + let loc = Location.make $startpos $endpos in + variable ~loc v + } + | LPAREN e = expr RPAREN + { + let loc = Location.make $startpos $endpos in + WrapLocation.update_location ~loc e + } + | e1 = expr COMMA e2 = expr + { + let loc = Location.make $startpos $endpos in + Value.pair ~loc (e1, e2) + } + | e1 = expr AT e2 = expr + { + let loc = Location.make $startpos $endpos in + application ~loc (e1, e2) + } + | e1 = expr DOT e2 = expr + { + let loc = Location.make $startpos $endpos in + application ~loc (e2, e1) + } +(* + | e = expr COLON t = type_expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ cast e t + } + | e1 = expr PLUS e2 = expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ primitive Plus [e1 ; e2] + } + | e1 = expr MINUS e2 = expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ primitive Minus [e1 ; e2] + } + | e1 = expr TIMES e2 = expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ primitive Times [e1 ; e2] + } + | e1 = expr DIV e2 = expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ primitive Div [e1 ; e2] + } + | e1 = expr EQUAL e2 = expr + { + let loc = Location.make $startpos $endpos in + make ~loc @@ primitive Equal [e1 ; e2] + } + | e = expr DOT v = VAR_NAME + { + let loc = Location.make $startpos $endpos in + make ~loc @@ dot e v + } +*) + +type_expr: + | t = TYPE_NAME + { + let loc = Location.make $startpos $endpos in + Type.(name ~loc t) + } + | t1 = type_expr AND t2 = type_expr + { + let loc = Location.make $startpos $endpos in + Type.(pair ~loc t1 t2) + } + | t1 = type_expr OR t2 = type_expr + { + let loc = Location.make $startpos $endpos in + Type.(union ~loc t1 t2) + } diff --git a/src/ligo/test/dune b/src/ligo/test/dune new file mode 100644 index 000000000..2d6816563 --- /dev/null +++ b/src/ligo/test/dune @@ -0,0 +1,10 @@ +(executable + (name test) + (libraries + ligo + alcotest + ) + (preprocess + (pps ppx_let) + ) +) diff --git a/src/ligo/test/test.ml b/src/ligo/test/test.ml new file mode 100644 index 000000000..3dc388f14 --- /dev/null +++ b/src/ligo/test/test.ml @@ -0,0 +1,186 @@ +(* -*- compile-command: "cd .. ; dune runtest" -*- *) + +open Ligo_helpers.Trace +open Ligo + +let test name f = + Alcotest.test_case name `Quick @@ fun _sw -> + match f () with + | Ok () -> () + | Errors errs -> + Format.printf "Errors : {\n%a}\n%!" errors_pp errs ; + raise Alcotest.Test_error + +open Mini_c +open Combinators + +let simple_int_program body : program = [ + Fun("main", function_int body) +] + +let run_int program n = + Run.run program (`Int n) >>? function + | `Int n -> ok n + | _ -> simple_fail "run_int : output not int" + +let neg () = + let program : program = simple_int_program [ + assign_variable "output" @@ neg_int (var_int "input") ; + assign_variable "output" @@ neg_int (var_int "output") ; + assign_variable "output" @@ neg_int (var_int "output") ; + ] in + run_int program 42 >>? fun output -> + Assert.assert_equal_int (-42) output >>? fun () -> + ok () + +let multiple_variables () = + let program = simple_int_program [ + assign_variable "a" @@ neg_int (var_int "input") ; + assign_variable "b" @@ neg_int (var_int "a") ; + assign_variable "c" @@ neg_int (var_int "b") ; + assign_variable "d" @@ neg_int (var_int "c") ; + assign_variable "output" @@ neg_int (var_int "d") ; + ] in + run_int program 42 >>? fun output -> + Assert.assert_equal_int (-42) output >>? fun () -> + ok () + +let arithmetic () = + let expression = add_int (var_int "input") (neg_int (var_int "input")) in + let program = simple_int_program [ + Assignment (Variable ("a", expression)) ; + Assignment (Variable ("b", var_int "a")) ; + Assignment (Variable ("output", var_int "b")) ; + ] in + let test n = + run_int program n >>? fun output -> + Assert.assert_equal_int 0 output >>? fun () -> + ok () + in + let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in + ok () + +let quote_ () = + let program = simple_int_program [ + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (int 42)] ; + assign_function "g" @@ function_int [assign_variable "output" @@ neg_int (var_int "input")] ; + assign_variable "output" @@ apply_int (type_f_int @@ var "g") @@ apply_int (type_f_int @@ var "f") (var_int "input") ; + ] in + let%bind output = run_int program 42 in + let%bind _ = Assert.assert_equal_int (-84) output in + ok () + +let function_ () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "input") (var_int "a")] ; + let env = Environment.Small.of_list ["a", t_int] in + assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; + ] in + let%bind output = run_int program 100 in + let%bind _ = Assert.assert_equal_int 142 output in + ok () + +let functions_ () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_variable "b" @@ int 144 ; + assign_function "f" @@ function_int [ + assign_variable "output" @@ add_int (var_int "input") (var_int "a") + ] ; + assign_function "g" @@ function_int [ + assign_variable "output" @@ add_int (var_int "input") (var_int "b") + ] ; + let env_f = Environment.Small.of_list ["a", t_int] in + let env_g = Environment.Small.of_list ["b", t_int] in + assign_variable "output" @@ add_int + (apply_int (type_closure_int env_f @@ var "f") (var_int "input")) + (apply_int (type_closure_int env_g @@ var "g") (var_int "input")) + ] in + let%bind output = run_int program 100 in + let%bind _ = Assert.assert_equal_int 386 output in + ok () + +let rich_function () = + let program = simple_int_program [ + assign_variable "a" @@ int 42 ; + assign_variable "b" @@ int 144 ; + assign_function "f" @@ function_int [assign_variable "output" @@ add_int (var_int "a") (var_int "b")] ; + let env = Environment.Small.of_list [("a", t_int) ; ("b", t_int)] in + assign_variable "output" @@ apply_int (type_closure_int env @@ var "f") (var_int "input") ; + ] in + let test n = + let%bind output = run_int program n in + let%bind _ = Assert.assert_equal_int 186 output in + ok () in + let%bind _assert = bind_list @@ List.map test [42 ; 150 ; 0 ; -42] in + ok () + +let main = "Mini_c", [ + test "basic.neg" neg ; + test "basic.variables" multiple_variables ; + test "basic.arithmetic" arithmetic ; + test "basic.quote" quote_ ; + test "basic.function" function_ ; + test "basic.functions" functions_ ; + test "basic.rich_function" rich_function ; + ] + +(* module Ligo = struct + * let parse_file (source:string) : Ligo.Untyped.Value.program result = + * let channel = open_in source in + * let lexbuf = Lexing.from_channel channel in + * specific_try (function + * | Parser.Error -> ( + * let start = Lexing.lexeme_start_p lexbuf in + * let end_ = Lexing.lexeme_end_p lexbuf in + * let str = Format.sprintf + * "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" + * (Lexing.lexeme lexbuf) + * start.pos_lnum (start.pos_cnum - start.pos_bol) + * end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in + * simple_error str + * ) + * | Lexer.Unexpected_character s -> simple_error s + * | Lexer.Error _ -> simple_error "lexer error" + * | _ -> simple_error "unrecognized parse_ error" + * ) @@ (fun () -> Parser.main Lexer.token lexbuf) >>? fun program_ast -> + * ok program_ast + * + * let run (source:string) (input:Ligo.Typed.Value.value) : Ligo.Typed.Value.value result = + * parse_file source >>? fun program_ast -> + * Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> + * Ligo.Run.run typed_program input >>? fun output -> + * ok output + * + * let assert_value_int : Ligo.Typed.Value.value -> int result = function + * | `Constant (`Int n) -> ok n + * | _ -> simple_fail "not an int" + * + * let basic () : unit result = + * run "./contracts/toto.ligo" (Ligo.Typed.Value.int 42) >>? fun output -> + * assert_value_int output >>? fun output -> + * Assert.assert_equal_int 42 output >>? fun () -> + * ok () + * + * let display_basic () : unit result = + * parse_file "./contracts/toto.ligo" >>? fun program_ast -> + * Ligo.Typecheck.typecheck_program program_ast >>? fun typed_program -> + * Ligo.Transpile.program_to_michelson typed_program >>? fun node -> + * let node = Tezos_utils.Cast.flatten_node node in + * let str = Tezos_utils.Cast.node_to_string node in + * Format.printf "Program:\n%s\n%!" str ; + * ok () + * + * let main = "Ligo", [ + * test "basic" basic ; + * test "basic.display" display_basic ; + * ] + * end *) + +let () = + (* Printexc.record_backtrace true ; *) + Alcotest.run "LIGO" [ + main ; + ] ; + ()