From 29959ec9153029c25fb37a5f12fdd61b7e25b0be Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 4 Feb 2020 20:21:13 +0100 Subject: [PATCH] Initial LIGO interpreter version --- src/main/compile/dune | 1 + src/main/compile/of_typed.ml | 2 + src/passes/6-interpreter/dune | 14 + src/passes/6-interpreter/interpreter.ml | 344 ++++++++++++++++++ src/passes/6-interpreter/interpreter.mli | 3 + src/stages/ligo_interpreter/PP.ml | 38 ++ src/stages/ligo_interpreter/dune | 14 + src/stages/ligo_interpreter/environment.ml | 14 + .../ligo_interpreter/ligo_interpreter.ml | 3 + src/stages/ligo_interpreter/types.ml | 40 ++ src/test/contracts/interpret_test.mligo | 150 ++++++++ vendors/ligo-utils/simple-utils/trace.ml | 1 + 12 files changed, 624 insertions(+) create mode 100644 src/passes/6-interpreter/dune create mode 100644 src/passes/6-interpreter/interpreter.ml create mode 100644 src/passes/6-interpreter/interpreter.mli create mode 100644 src/stages/ligo_interpreter/PP.ml create mode 100644 src/stages/ligo_interpreter/dune create mode 100644 src/stages/ligo_interpreter/environment.ml create mode 100644 src/stages/ligo_interpreter/ligo_interpreter.ml create mode 100644 src/stages/ligo_interpreter/types.ml create mode 100644 src/test/contracts/interpret_test.mligo diff --git a/src/main/compile/dune b/src/main/compile/dune index 90c858e1d..e59679ba5 100644 --- a/src/main/compile/dune +++ b/src/main/compile/dune @@ -6,6 +6,7 @@ tezos-utils parser simplify + interpreter ast_simplified self_ast_simplified typer_new diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 75f4afae3..43b2216fe 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -27,3 +27,5 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As let pretty_print ppf program = Ast_typed.PP.program ppf program + +let some_interpret = Interpreter.dummy diff --git a/src/passes/6-interpreter/dune b/src/passes/6-interpreter/dune new file mode 100644 index 000000000..d71a1f835 --- /dev/null +++ b/src/passes/6-interpreter/dune @@ -0,0 +1,14 @@ +(library + (name interpreter) + (public_name ligo.interpreter) + (libraries + simple-utils + tezos-utils + ast_typed + ligo_interpreter + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -w +1..62-4-9-44-40-42-48-30@39@33 -open Simple_utils )) +) diff --git a/src/passes/6-interpreter/interpreter.ml b/src/passes/6-interpreter/interpreter.ml new file mode 100644 index 000000000..4d950fc18 --- /dev/null +++ b/src/passes/6-interpreter/interpreter.ml @@ -0,0 +1,344 @@ +open Trace +open Ligo_interpreter.Types +include Stage_common.Types + +module Env = Ligo_interpreter.Environment + +let apply_comparison : Ast_typed.constant -> value list -> value result = + fun c operands -> match (c,operands) with + | ( comp , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) + | ( comp , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) + | ( comp , [ V_Ct (C_mutez a' ) ; V_Ct (C_mutez b' ) ] ) + | ( comp , [ V_Ct (C_timestamp a') ; V_Ct (C_timestamp b') ] ) -> + let f_op = match comp with + | C_EQ -> Int.equal + | C_NEQ -> fun a b -> not (Int.equal a b) + | C_LT -> (<) + | C_LE -> (<=) + | C_GT -> (>) + | C_GE -> (>=) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + + | ( comp , [ V_Ct (C_string a' ) ; V_Ct (C_string b' ) ] ) + | ( comp , [ V_Ct (C_address a' ) ; V_Ct (C_address b' ) ] ) + | ( comp , [ V_Ct (C_key_hash a') ; V_Ct (C_key_hash b') ] ) -> + let f_op = match comp with + | C_EQ -> fun a b -> (String.compare a b = 0) + | C_NEQ -> fun a b -> (String.compare a b != 0) + (* the above might not be alligned with Michelson interpreter. Do we care ? *) + | C_LT -> fun a b -> (String.compare a b < 0) + | C_LE -> fun a b -> (String.compare a b <= 0) + | C_GT -> fun a b -> (String.compare a b > 0) + | C_GE -> fun a b -> (String.compare a b >= 0) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + + | ( comp , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> + let f_op = match comp with + | C_EQ -> fun a b -> (Bytes.compare a b = 0) + | C_NEQ -> fun a b -> (Bytes.compare a b != 0) + (* the above might not be alligned with Michelson interpreter. Do we care ? *) + | C_LT -> fun a b -> (Bytes.compare a b < 0) + | C_LE -> fun a b -> (Bytes.compare a b <= 0) + | C_GT -> fun a b -> (Bytes.compare a b > 0) + | C_GE -> fun a b -> (Bytes.compare a b >= 0) + | _ -> failwith "apply compare must be called with a comparative constant" in + ok @@ V_Ct (C_bool (f_op a' b')) + | _ -> simple_fail "unsupported comparison" + +(* applying those operators does not involve extending the environment *) +let rec apply_operator : Ast_typed.constant -> value list -> value result = + fun c operands -> + let return_ct v = ok @@ V_Ct v in + let return_none () = ok @@ V_Construct ("None" , V_Ct C_unit) in + let return_some v = ok @@ V_Construct ("Some" , v) in + ( match (c,operands) with + (* nullary *) + | ( C_NONE , [] ) -> return_none () + | ( C_UNIT , [] ) -> ok @@ V_Ct C_unit + | ( C_NIL , [] ) -> ok @@ V_List [] + (* unary *) + | ( C_FAILWITH , [ V_Ct (C_string a') ] ) -> + (*TODO This raise is here until we properly implement effects*) + raise (Temprorary_hack a') + (*TODO This raise is here until we properly implement effects*) + | ( C_NOT , [ V_Ct (C_bool a' ) ] ) -> return_ct @@ C_bool (not a') + | ( C_INT , [ V_Ct (C_nat a') ] ) -> return_ct @@ C_int a' + | ( C_ABS , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (abs a') + | ( C_NEG , [ V_Ct (C_int a') ] ) -> return_ct @@ C_int (-a') + | ( C_SOME , [ v ] ) -> return_some v + | ( C_IS_NAT , [ V_Ct (C_int a') ] ) -> + if a' > 0 then return_some @@ V_Ct (C_nat a') + else return_none () + (* binary *) + | ( (C_EQ | C_NEQ | C_LT | C_LE | C_GT | C_GE) , _ ) -> apply_comparison c operands + | ( C_SUB , [ V_Ct (C_int a' | C_nat a') ; V_Ct (C_int b' | C_nat b') ] ) -> return_ct @@ C_int (a' - b') + | ( C_CONS , [ v ; V_List vl ] ) -> ok @@ V_List (v::vl) + | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' + b') + | ( C_MUL , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' * b') + | ( C_MUL , [ V_Ct (C_nat a' ) ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_MUL , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_mutez (a' * b') + | ( C_DIV , [ V_Ct (C_int a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' / b') + | ( C_DIV , [ V_Ct (C_nat a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_nat (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_mutez (a' / b') + | ( C_DIV , [ V_Ct (C_mutez a') ; V_Ct (C_mutez b') ] ) -> return_ct @@ C_nat (a' / b') + | ( C_CONCAT , [ V_Ct (C_string a') ; V_Ct (C_string b') ] ) -> return_ct @@ C_string (a' ^ b') + | ( C_CONCAT , [ V_Ct (C_bytes a' ) ; V_Ct (C_bytes b' ) ] ) -> return_ct @@ C_bytes (Bytes.cat a' b') + | ( C_OR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' || b') + | ( C_AND , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool (a' && b') + | ( C_XOR , [ V_Ct (C_bool a' ) ; V_Ct (C_bool b' ) ] ) -> return_ct @@ C_bool ( (a' || b') && (not (a' && b')) ) + | ( C_LIST_MAP , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> + let%bind elts' = bind_map_list + (fun elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env') + elts in + ok @@ V_List elts' + | ( C_LIST_ITER , [ V_Func_val (arg_name, body, env) ; V_List (elts) ] ) -> + bind_fold_list + (fun _ elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env' + ) + (V_Ct C_unit) elts + (* tertiary *) + | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List (elts) ; init ] ) -> + bind_fold_list + (fun prev elt -> + let fold_args = V_Record (LMap.of_list [(Label "0",prev) ; (Label "1",elt)]) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init elts + | _ -> + let () = Format.printf "%a\n" Stage_common.PP.constant c in + let () = List.iter ( fun e -> Format.printf "%s\n" (Ligo_interpreter.PP.pp_value e)) operands in + simple_fail "Unsupported constant op" + ) + +(* +| C_NOW +| C_ASSERTION +| C_ASSERT_INFERRED +| C_UPDATE +| C_ITER +| C_FOLD_WHILE +| C_CONTINUE +| C_STOP +| C_FOLD +| C_SUB +| C_MOD +| C_SIZE +| C_SLICE +| C_BYTES_PACK +| C_BYTES_UNPACK +| C_PAIR +X| C_CAR +X| C_CDR +X| C_LEFT +X| C_RIGHT +| C_SET_EMPTY +| C_SET_LITERAL +| C_SET_ADD +| C_SET_REMOVE +| C_SET_ITER +| C_SET_FOLD +| C_SET_MEM +| C_MAP +| C_MAP_EMPTY +| C_MAP_LITERAL +| C_MAP_GET +| C_MAP_GET_FORCE +| C_MAP_ADD +| C_MAP_REMOVE +| C_MAP_UPDATE +| C_MAP_ITER +| C_MAP_MAP +| C_MAP_FOLD +| C_MAP_MEM +| C_MAP_FIND +| C_MAP_FIND_OPT +| C_BIG_MAP +| C_BIG_MAP_EMPTY +| C_BIG_MAP_LITERAL +x| C_LIST_CONS -> To remove ? seems unused +| C_SHA256 +| C_SHA512 +| C_BLAKE2b +| C_HASH +| C_HASH_KEY +| C_CHECK_SIGNATURE +| C_CHAIN_ID +| C_CALL +| C_CONTRACT +| C_CONTRACT_ENTRYPOINT +| C_AMOUNT +| C_BALANCE +| C_SOURCE +| C_SENDER +| C_ADDRESS +| C_SELF_ADDRESS +| C_IMPLICIT_ACCOUNT +| C_SET_DELEGATE +| C_STEPS_TO_QUOTA +*) + +(*interpreter*) +and eval_literal : Ast_typed.literal -> value result = function + | Literal_unit -> ok @@ V_Ct (C_unit) + | Literal_int i -> ok @@ V_Ct (C_int i) + | Literal_nat n -> ok @@ V_Ct (C_nat n) + | Literal_string s -> ok @@ V_Ct (C_string s) + | Literal_bytes s -> ok @@ V_Ct (C_bytes s) + | Literal_bool b -> ok @@ V_Ct (C_bool b) + | Literal_mutez t -> ok @@ V_Ct (C_mutez t) + | _ -> simple_fail "Unsupported literal" + +and eval : Ast_typed.expression -> env -> value result + = fun term env -> + match term with + | E_application ({expression = f; _}, args) -> ( + let%bind f' = match f with + | E_variable f -> Env.lookup env f + | _ -> eval f env in + match f' with + | V_Func_val (arg_names, body, f_env) -> + let%bind args' = eval args.expression env in + let f_env' = Env.extend f_env (arg_names, args') in + eval body f_env' + | _ -> simple_fail "trying to apply on something that is not a function" + ) + | E_lambda { binder; body;} -> + ok @@ V_Func_val (binder,body.expression,env) + | E_let_in { binder; rhs; result; _} -> + let%bind rhs' = eval rhs.expression env in + eval result.expression (Env.extend env (binder,rhs')) + | E_map kvlist | E_big_map kvlist -> + let%bind kvlist' = bind_map_list + (fun kv -> bind_map_pair (fun (el:Ast_typed.annotated_expression) -> eval el.expression env) kv) + kvlist in + ok @@ V_Map kvlist' + | E_list expl -> + let%bind expl' = bind_map_list + (fun (exp:Ast_typed.annotated_expression) -> eval exp.expression env) + expl in + ok @@ V_List expl' + | E_literal l -> + eval_literal l + | E_variable var -> + Env.lookup env var + | E_record recmap -> + let%bind lv' = bind_map_list + (fun (label,(v:Ast_typed.annotated_expression)) -> + let%bind v' = eval v.expression env in + ok (label,v')) + (LMap.to_kv_list recmap) in + ok @@ V_Record (LMap.of_list lv') + | E_record_accessor (record,label) -> ( + let%bind record' = eval record.expression env in + match record' with + | V_Record recmap -> + let%bind a = trace_option (simple_error "unknown record field") @@ + LMap.find_opt label recmap in + ok a + | _ -> simple_fail "trying to access a non-record" + ) + | E_record_update (record, (l,field)) -> ( + let%bind record' = eval record.expression env in + match record' with + | V_Record recmap -> + if LMap.mem l recmap then + let%bind field' = eval field.expression env in + ok @@ V_Record (LMap.add l field' recmap) + else + simple_fail "field l does not exist in record" + | _ -> simple_fail "this expression isn't a record" + ) + | E_constant (op, operands) -> ( + let%bind operands' = bind_map_list + (fun (ae:Ast_typed.annotated_expression) -> eval ae.expression env) + operands in + apply_operator op operands' + ) + | E_constructor (Constructor c, v) -> + let%bind v' = eval v.expression env in + ok @@ V_Construct (c,v') + | E_matching (e , cases) -> ( + let%bind e' = eval e.expression env in + match cases, e' with + | Match_list cases , V_List [] -> + eval cases.match_nil.expression env + | Match_list cases , V_List (head::tail) -> + let (head_var,tail_var,body,_) = cases.match_cons in + let env' = Env.extend (Env.extend env (head_var,head)) (tail_var, V_List tail) in + eval body.expression env' + | Match_variant (case_list , _) , V_Construct (matched_c , proj) -> + let ((_, var) , body) = + List.find + (fun case -> + let (Constructor c , _) = fst case in + String.equal matched_c c) + case_list in + let env' = Env.extend env (var, proj) in + eval body.expression env' + | Match_bool cases , V_Ct (C_bool true) -> + eval cases.match_true.expression env + | Match_bool cases , V_Ct (C_bool false) -> + eval cases.match_false.expression env + | Match_option cases, V_Construct ("Some" , proj) -> + let (var,body,_) = cases.match_some in + let env' = Env.extend env (var,proj) in + eval body.expression env' + | Match_option cases, V_Construct ("None" , V_Ct C_unit) -> + eval cases.match_none.expression env + | _ -> simple_fail "not yet supported case" + (* ((ctor,name),body) *) + ) + (********************************************** + This is not necessary after Ast simplification + ***********************************************) + | E_tuple el -> + let%bind lv = bind_mapi_list + (fun i (el:Ast_typed.annotated_expression) -> + let%bind el' = eval el.expression env in + ok (Label (string_of_int i), el')) + el in + ok @@ V_Record (LMap.of_list lv) + | E_tuple_accessor (tuple,i) -> ( + let%bind record' = eval tuple.expression env in + match record' with + | V_Record recmap -> + let label = Label (string_of_int i) in + let%bind a = trace_option (simple_error "out of tuple range") @@ + LMap.find_opt label recmap in + ok a + | _ -> simple_fail "trying to access a non-record" + ) + (********************************************** + This is not necessary after Ast simplification + ***********************************************) + | E_look_up _ | E_loop _ | E_set _ | E_sequence _ | E_assign _-> + let serr = Format.asprintf "Unsupported construct :\n %a\n" Ast_typed.PP.expression term in + simple_fail serr + +let dummy : Ast_typed.program -> string result = + fun prg -> + let%bind (res,_) = bind_fold_list + (fun (pp,top_env) el -> + let (Ast_typed.Declaration_constant (named_exp, _, _)) = Location.unwrap el in + let%bind v = + (*TODO This TRY-CATCH is here until we properly implement effects*) + try + eval named_exp.annotated_expression.expression top_env + with Temprorary_hack s -> ok @@ V_Failure s + (*TODO This TRY-CATCH is here until we properly implement effects*) + in + let pp' = pp^"\n val "^(Var.to_name named_exp.name)^" = "^(Ligo_interpreter.PP.pp_value v) in + let top_env' = Env.extend top_env (named_exp.name, v) in + ok @@ (pp',top_env') + ) + ("",Env.empty_env) prg in + ok @@ res diff --git a/src/passes/6-interpreter/interpreter.mli b/src/passes/6-interpreter/interpreter.mli new file mode 100644 index 000000000..9e7820e1a --- /dev/null +++ b/src/passes/6-interpreter/interpreter.mli @@ -0,0 +1,3 @@ +open Trace + +val dummy : Ast_typed.program -> string result \ No newline at end of file diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml new file mode 100644 index 000000000..8a1cb8bd2 --- /dev/null +++ b/src/stages/ligo_interpreter/PP.ml @@ -0,0 +1,38 @@ +open Types + +let rec pp_value : value -> string = function + | V_Ct (C_int i) -> Format.asprintf "%i : int" i + | V_Ct (C_nat n) -> Format.asprintf "%i : nat" n + | V_Ct (C_string s) -> Format.asprintf "\"%s\" : string" s + | V_Ct (C_unit) -> Format.asprintf "unit" + | V_Ct (C_bool true) -> Format.asprintf "true" + | V_Ct (C_bool false) -> Format.asprintf "false" + | V_Ct (C_bytes b) -> Format.asprintf "0x%a : bytes" Hex.pp (Hex.of_bytes b) + | V_Ct (C_mutez i) -> Format.asprintf "%i : mutez" i + | V_Ct _ -> Format.asprintf "PP, TODO" + | V_Failure s -> Format.asprintf "\"%s\" : failure " s + | V_Record recmap -> + let content = LMap.fold (fun label field prev -> + let (Label l) = label in + Format.asprintf "%s ; %s = (%s)" prev l (pp_value field)) + recmap "" in + Format.asprintf "{ %s }" content + | V_Func_val _ -> Format.asprintf "" + | V_Construct (name,v) -> Format.asprintf "%s(%s)" name (pp_value v) + | V_List vl -> + Format.asprintf "[ %s ]" @@ + List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" vl + | V_Map vmap -> + Format.asprintf "[ %s ]" @@ + List.fold_left (fun prev (k,v) -> Format.asprintf "%s ; %s -> %s" prev (pp_value k) (pp_value v)) "" vmap + | V_Set slist -> + Format.asprintf "{ %s }" @@ + List.fold_left (fun prev v -> Format.asprintf "%s ; %s" prev (pp_value v)) "" slist + +let pp_env : env -> unit = fun env -> + let () = Format.printf "{ #elements : %i\n" @@ Env.cardinal env in + let () = Env.iter (fun var v -> + Format.printf "\t%s -> %s\n" (Var.to_name var) (pp_value v)) + env in + let () = Format.printf "\n}\n" in + () \ No newline at end of file diff --git a/src/stages/ligo_interpreter/dune b/src/stages/ligo_interpreter/dune new file mode 100644 index 000000000..211275847 --- /dev/null +++ b/src/stages/ligo_interpreter/dune @@ -0,0 +1,14 @@ +(library + (name ligo_interpreter) + (public_name ligo.ligo_interpreter) + (libraries + simple-utils + tezos-utils + ast_typed + stage_common + ) + (preprocess + (pps ppx_let bisect_ppx --conditional) + ) + (flags (:standard -open Simple_utils)) +) diff --git a/src/stages/ligo_interpreter/environment.ml b/src/stages/ligo_interpreter/environment.ml new file mode 100644 index 000000000..5c1da4661 --- /dev/null +++ b/src/stages/ligo_interpreter/environment.ml @@ -0,0 +1,14 @@ +open Trace +open Types + +let extend : + env -> (expression_variable * value) -> env + = fun env (var,exp) -> Env.add var exp env + +let lookup : + env -> expression_variable -> value result + = fun env var -> match Env.find_opt var env with + | Some res -> ok res + | None -> simple_fail "TODO: not found in env" + +let empty_env = Env.empty \ No newline at end of file diff --git a/src/stages/ligo_interpreter/ligo_interpreter.ml b/src/stages/ligo_interpreter/ligo_interpreter.ml new file mode 100644 index 000000000..b0722ca9f --- /dev/null +++ b/src/stages/ligo_interpreter/ligo_interpreter.ml @@ -0,0 +1,3 @@ +module Types = Types +module PP = PP +module Environment = Environment \ No newline at end of file diff --git a/src/stages/ligo_interpreter/types.ml b/src/stages/ligo_interpreter/types.ml new file mode 100644 index 000000000..b39ac7605 --- /dev/null +++ b/src/stages/ligo_interpreter/types.ml @@ -0,0 +1,40 @@ +include Stage_common.Types + +(*types*) +module Env = Map.Make( + struct + type t = expression_variable + let compare a b = Var.compare a b + end +) + +(*TODO temporary hack to handle failwiths *) +exception Temprorary_hack of string + +type env = value Env.t + +and constant_val = + | C_unit + | C_bool of bool + | C_int of int + | C_nat of int + | C_timestamp of int + | C_mutez of int + | C_string of string + | C_bytes of bytes + | C_address of string + | C_signature of string + | C_key of string + | C_key_hash of string + | C_chain_id of string + | C_operation of Memory_proto_alpha.Protocol.Alpha_context.packed_internal_operation + +and value = + | V_Func_val of (expression_variable * Ast_typed.expression * env) + | V_Ct of constant_val + | V_List of value list + | V_Record of value label_map + | V_Map of (value * value) list + | V_Set of value list + | V_Construct of (string * value) + | V_Failure of string (*temporary*) diff --git a/src/test/contracts/interpret_test.mligo b/src/test/contracts/interpret_test.mligo new file mode 100644 index 000000000..c47ef6150 --- /dev/null +++ b/src/test/contracts/interpret_test.mligo @@ -0,0 +1,150 @@ +let lambda_call = + let a = 3 in + let foo: (int -> int) = + fun (i : int) -> i * i + in + foo (a + 1) + +let higher_order1 = + let a = 2 in + let foo: (int -> int -> int -> int) = + fun (i:int) (j:int) (k:int) -> a + i + j + 0 + in + let bar = (foo 1 2) in + bar 3 + +let higher_order2 = + let a = 2 in + let foo: (int -> int) = + fun (i:int) -> + let b = 2 in + let bar : (int -> int) = + fun (i:int) -> i + a + b + in bar i + in foo 1 + +let concats = + 0x70 ^ 0x70 + +type foo_record = { + a : string ; + b : string ; +} +let record_concat = + let ab : foo_record = { a = "a" ; b = "b" } in + ab.a ^ ab.b + +let record_patch = + let ab : foo_record = { a = "a" ; b = "b" } in + {ab with b = "c"} + +type bar_record = { + f : int -> int ; + arg : int ; +} +let record_lambda = + let a = 1 in + let foo : (int -> int) = fun (i:int) -> a+(i*2) in + let farg : bar_record = { f = foo ; arg = 2 } in + farg.f farg.arg + +type foo_variant = +| Foo +| Bar of int +| Baz of string + +let variant_exp = + (Foo, Bar 1, Baz "b") + +let variant_match = + let a = Bar 1 in + match a with + | Foo -> 1 + | Bar(i) -> 2 + | Baz(s) -> 3 + +/* UNSUPPORTED +type bar_variant = +| Baz +| Buz of int * int +| Biz of int * int * string +let long_variant_match = + let a = Biz (1,2,"Biz") in + match a with + | Baz -> "Baz" + | Buz(a,b) -> "Buz" + | Biz(a,b,c) -> c +*/ + +let bool_match = + let b = true in + match b with + | true -> 1 + | false -> 2 + +let list_match = + let a = [ 1 ; 2 ; 3 ; 4 ] in + match a with + | hd :: tl -> hd::a + | [] -> a + +let tuple_proj = + let (a,b) = (true,false) in + a or b + +let list_const = + let a = [1 ; 2 ; 3 ; 4] in + 0 :: a + +type foobar = int option + +let options_match_some = + let a = Some 0 in + match a with + | Some(i) -> i + | None -> 1 + +let options_match_none = + let a : foobar = None in + match a with + | Some(i) -> i + | None -> 0 + +let is_nat_nat = + let i : int = 1 in + let j : int = -1 in + (Michelson.is_nat i, Michelson.is_nat j) + +let abs_int = abs (-5) + +let nat_int = int (5n) + +let map_list = + let a = [1 ; 2 ; 3 ; 4] in + let add_one: (int -> int) = fun (i : int) -> i + 1 in + List.map add_one a + +let fail_alone = failwith "you failed" + +let iter_list_fail = + let a = [1 ; 2 ; 3 ; 4] in + let check_something: (int -> unit) = fun (i : int) -> + if i = 2 then failwith "you failed" + else () + in + List.iter check_something a + +let fold_list = + let a = [1 ; 2 ; 3 ; 4] in + let acc : (int * int -> int) = + fun (prev, el : int * int) -> prev + el in + List.fold acc a 0 + +let comparison_int = + (1 > 2, 2 > 1, 1 >=2 , 2 >= 1) + +let comparison_string = + ("foo" = "bar", "baz" = "baz") + +let divs : (int * nat * tez * nat) = + (1/2 , 1n/2n , 1tz/2n , 1tz/2tz) \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 3ff26b4aa..6b7cdde70 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -555,6 +555,7 @@ let bind_concat (l1:'a list result) (l2: 'a list result) = ok @@ (l1' @ l2') let bind_map_list f lst = bind_list (List.map f lst) +let bind_mapi_list f lst = bind_list (List.mapi f lst) let rec bind_map_list_seq f lst = match lst with | [] -> ok []