diff --git a/.gitignore b/.gitignore index d2d2464e1..7c9d772a8 100644 --- a/.gitignore +++ b/.gitignore @@ -5,9 +5,11 @@ cache/* Version.ml /_opam/ /*.pp.ligo +/*.pp.mligo +/*.pp.religo **/.DS_Store .vscode/ /ligo.install *.coverage /_coverage/ -/_coverage_*/ +/_coverage_*/ \ No newline at end of file diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 21f888c07..92716d380 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -268,6 +268,19 @@ let interpret = let doc = "Subcommand: Interpret the expression in the context initialized by the provided source file." in (Term.ret term , Term.info ~doc cmdname) +let temp_ligo_interpreter = + let f source_file syntax display_format = + toplevel ~display_format @@ + let%bind simplified = Compile.Of_source.compile source_file (Syntax_name syntax) in + let%bind typed,_ = Compile.Of_simplified.compile simplified in + let%bind res = Compile.Of_typed.some_interpret typed in + ok @@ Format.asprintf "%s\n" res + in + let term = + Term.(const f $ source_file 0 $ syntax $ display_format ) in + let cmdname = "ligo-interpret" in + let doc = "Subcommand: (temporary / dev only) uses LIGO interpret." in + (Term.ret term , Term.info ~doc cmdname) let compile_storage = let f source_file entry_point expression syntax amount sender source predecessor_timestamp display_format michelson_format = @@ -426,6 +439,7 @@ let list_declarations = let run ?argv () = Term.eval_choice ?argv main [ + temp_ligo_interpreter ; compile_file ; measure_contract ; compile_parameter ; diff --git a/src/bin/expect_tests/help_tests.ml b/src/bin/expect_tests/help_tests.ml index 06e877a32..bd5824881 100644 --- a/src/bin/expect_tests/help_tests.ml +++ b/src/bin/expect_tests/help_tests.ml @@ -44,6 +44,9 @@ let%expect_test _ = Subcommand: Interpret the expression in the context initialized by the provided source file. + ligo-interpret + Subcommand: (temporary / dev only) uses LIGO interpret. + list-declarations Subcommand: List all the top-level declarations. @@ -120,6 +123,9 @@ let%expect_test _ = Subcommand: Interpret the expression in the context initialized by the provided source file. + ligo-interpret + Subcommand: (temporary / dev only) uses LIGO interpret. + list-declarations Subcommand: List all the top-level declarations. diff --git a/src/bin/expect_tests/ligo_interpreter_tests.ml b/src/bin/expect_tests/ligo_interpreter_tests.ml new file mode 100644 index 000000000..ac381ea71 --- /dev/null +++ b/src/bin/expect_tests/ligo_interpreter_tests.ml @@ -0,0 +1,56 @@ +open Cli_expect + +let contract basename = + "../../test/contracts/" ^ basename + +let%expect_test _ = + run_ligo_good [ "ligo-interpret" ; contract "interpret_test.mligo" ] ; + [%expect {| + val lambda_call = 16 : int + val higher_order1 = 5 : int + val higher_order2 = 5 : int + val higher_order3 = 5 : int + val higher_order4 = 5 : int + val concats = 0x7070 : bytes + val record_concat = "ab" : string + val record_patch = { ; a = ("a" : string) ; b = ("c" : string) } + val record_lambda = 5 : int + val variant_exp = { ; 0 = (Foo(unit)) ; 1 = (Bar(1 : int)) ; 2 = (Baz("b" : string)) } + val variant_match = 2 : int + val bool_match = 1 : int + val list_match = [ ; 1 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int] + val tuple_proj = true + val list_const = [ ; 0 : int ; 1 : int ; 2 : int ; 3 : int ; 4 : int] + val options_match_some = 0 : int + val options_match_none = 0 : int + val is_nat_nat = { ; 0 = (Some(1 : nat)) ; 1 = (None(unit)) } + val abs_int = 5 : int + val nat_int = 5 : int + val map_list = [ ; 2 : int ; 3 : int ; 4 : int ; 5 : int] + val fail_alone = "you failed" : failure + val iter_list_fail = "you failed" : failure + val fold_list = 10 : int + val comparison_int = { ; 0 = (false) ; 1 = (true) ; 2 = (false) ; 3 = (true) } + val comparison_string = { ; 0 = (false) ; 1 = (true) } + val divs = { ; 0 = (0 : int) ; 1 = (0 : nat) ; 2 = (500000 : mutez) ; 3 = (0 : nat) } + val var_neg = -2 : int + val sizes = { ; 0 = (5 : nat) ; 1 = (5 : nat) ; 2 = (5 : nat) ; 3 = (3 : nat) ; 4 = (2 : nat) } + val modi = 1 : nat + val fold_while = { ; 0 = (20 : int) ; 1 = (10 : int) } + val assertion_pass = unit + val assertion_fail = "failed assertion" : failure + val lit_address = "KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" : address + val map_finds = Some(2 : int) + val map_finds_fail = "failed map find" : failure + val map_empty = { ; 0 = ([]) ; 1 = ([]) } + val m = [ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int] + val map_fold = 4 : int + val map_iter = unit + val map_map = [ ; "one" : string -> 4 : int ; "two" : string -> 5 : int ; "three" : string -> 8 : int] + val map_mem = { ; 0 = (true) ; 1 = (false) } + val map_remove = { ; 0 = ([ ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) ; 1 = ([ ; "one" : string -> 1 : int ; "two" : string -> 2 : int ; "three" : string -> 3 : int]) } + val map_update = { ; 0 = ([ ; "one" : string -> 1 : int]) ; 1 = ([]) ; 2 = ([]) ; 3 = ([ ; "one" : string -> 1 : int]) } + val s = { ; 1 : int ; 2 : int ; 3 : int} + val set_add = { ; 0 = ({ ; 1 : int ; 2 : int ; 3 : int}) ; 1 = ({ ; 1 : int ; 2 : int ; 3 : int ; 4 : int}) ; 2 = ({ ; 1 : int}) } + val set_iter_fail = "set_iter_fail" : failure + val set_mem = { ; 0 = (true) ; 1 = (false) ; 2 = (false) } |}] ; \ No newline at end of file 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..5b44d5b11 --- /dev/null +++ b/src/passes/6-interpreter/interpreter.ml @@ -0,0 +1,395 @@ +open Trace +open Ligo_interpreter.Types +open Ligo_interpreter.Combinators +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_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_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_bool (f_op a' b') + | _ -> + let () = List.iter (fun el -> Format.printf "%s" (Ligo_interpreter.PP.pp_value el)) operands in + 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_none () in + let return_some v = ok @@ v_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 (Temporary_hack a') + (*TODO This raise is here until we properly implement effects*) + + | ( C_SIZE , [(V_Set l | V_List l)] ) -> return_ct @@ C_nat (List.length l) + | ( C_SIZE , [ V_Map l ] ) -> return_ct @@ C_nat (List.length l) + | ( C_SIZE , [ V_Ct (C_string s ) ] ) -> return_ct @@ C_nat (String.length s) + | ( C_SIZE , [ V_Ct (C_bytes b ) ] ) -> return_ct @@ C_nat (Bytes.length b) + | ( 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 () + | ( C_CONTINUE , [ v ] ) -> ok @@ v_pair (v_bool true , v) + | ( C_STOP , [ v ] ) -> ok @@ v_pair (v_bool false , v) + | ( C_ASSERTION , [ v ] ) -> + let%bind pass = is_true v in + if pass then return_ct @@ C_unit + else raise (Temporary_hack "failed assertion") + | C_MAP_FIND_OPT , [ k ; V_Map l ] -> ( match List.assoc_opt k l with + | Some v -> ok @@ v_some v + | None -> ok @@ v_none () + ) + | C_MAP_FIND , [ k ; V_Map l ] -> ( match List.assoc_opt k l with + | Some v -> ok @@ v + | None -> raise (Temporary_hack "failed map find") + ) + (* 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_ADD , [ V_Ct (C_nat a' ) ; V_Ct (C_int b' ) ] ) -> return_ct @@ C_int (a' + b') + | ( C_ADD , [ V_Ct (C_int a' ) ; V_Ct (C_nat b' ) ] ) -> return_ct @@ C_int (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_MOD , [ V_Ct (C_int a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_nat a') ; V_Ct (C_int b') ] ) -> return_ct @@ C_nat (a' mod b') + | ( C_MOD , [ V_Ct (C_int a') ; V_Ct (C_nat b') ] ) -> return_ct @@ C_nat (a' mod 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_MAP_MAP , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) -> + let%bind elts' = bind_map_list + (fun (k,v) -> + let env' = Env.extend env (arg_name,v_pair (k,v)) in + let%bind v' = eval body env' in + ok @@ (k,v') + ) + elts in + ok @@ V_Map 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 + | ( C_MAP_ITER , [ V_Func_val (arg_name, body, env) ; V_Map (elts) ] ) -> + bind_fold_list + (fun _ kv -> + let env' = Env.extend env (arg_name,v_pair kv) in + eval body env' + ) + (V_Ct C_unit) elts + | ( C_FOLD_WHILE , [ V_Func_val (arg_name, body, env) ; init ] ) -> + let rec aux el = + let%bind (b,folded_val) = extract_pair el in + let env' = Env.extend env (arg_name, folded_val) in + let%bind res = eval body env' in + let%bind continue = is_true b in + if continue then aux res else ok folded_val in + aux @@ v_pair (v_bool true,init) + (* tertiary *) + | ( C_SLICE , [ V_Ct (C_nat st) ; V_Ct (C_nat ed) ; V_Ct (C_string s) ] ) -> + generic_try (simple_error "bad slice") @@ (fun () -> + V_Ct (C_string (String.sub s st ed)) + ) + | ( C_LIST_FOLD , [ V_Func_val (arg_name, body, env) ; V_List elts ; init ] ) -> + bind_fold_list + (fun prev elt -> + let fold_args = v_pair (prev,elt) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init elts + | ( C_MAP_FOLD , [ V_Func_val (arg_name, body, env) ; V_Map kvs ; init ] ) -> + bind_fold_list + (fun prev kv -> + let fold_args = v_pair (prev, v_pair kv) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init kvs + | ( C_MAP_MEM , [ k ; V_Map kvs ] ) -> ok @@ v_bool (List.mem_assoc k kvs) + | ( C_MAP_ADD , [ k ; v ; V_Map kvs as vmap] ) -> + if (List.mem_assoc k kvs) then ok vmap + else ok (V_Map ((k,v)::kvs)) + | ( C_MAP_REMOVE , [ k ; V_Map kvs] ) -> ok @@ V_Map (List.remove_assoc k kvs) + | ( C_MAP_UPDATE , [ k ; V_Construct (option,v) ; V_Map kvs] ) -> (match option with + | "Some" -> ok @@ V_Map ((k,v)::(List.remove_assoc k kvs)) + | "None" -> ok @@ V_Map (List.remove_assoc k kvs) + | _ -> simple_fail "update without an option" + ) + | ( C_SET_ADD , [ v ; V_Set l ] ) -> ok @@ V_Set (List.sort_uniq compare (v::l)) + | ( C_SET_FOLD , [ V_Func_val (arg_name, body, env) ; V_Set elts ; init ] ) -> + bind_fold_list + (fun prev elt -> + let fold_args = v_pair (prev,elt) in + let env' = Env.extend env (arg_name, fold_args) in + eval body env' + ) + init elts + | ( C_SET_ITER , [ V_Func_val (arg_name, body, env) ; V_Set (elts) ] ) -> + bind_fold_list + (fun _ elt -> + let env' = Env.extend env (arg_name,elt) in + eval body env' + ) + (V_Ct C_unit) elts + | ( C_SET_MEM , [ v ; V_Set (elts) ] ) -> ok @@ v_bool (List.mem v elts) + | ( C_SET_REMOVE , [ v ; V_Set (elts) ] ) -> ok @@ V_Set (List.filter (fun el -> not (el = v)) 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" + ) + +(* TODO + +hash on bytes +C_BLAKE2b +C_SHA256 +C_SHA512 +hash on key +C_HASH_KEY + +need exts +C_AMOUNT +C_BALANCE +C_CHAIN_ID +C_CONTRACT_ENTRYPOINT_OPT +C_CONTRACT_OPT +C_CONTRACT +C_CONTRACT_ENTRYPOINT +C_SELF_ADDRESS +C_SOURCE +C_SENDER +C_NOW +C_IMPLICIT_ACCOUNT + +C_CALL +C_SET_DELEGATE + +C_BYTES_PACK +C_BYTES_UNPACK +C_CHECK_SIGNATURE +C_ADDRESS + + +WONT DO: +C_STEPS_TO_QUOTA + +*) + +(*interpreter*) +and eval_literal : Ast_typed.literal -> value result = function + | Literal_unit -> ok @@ V_Ct (C_unit) + | Literal_bool b -> ok @@ V_Ct (C_bool b) + | Literal_int i -> ok @@ V_Ct (C_int i) + | Literal_nat n -> ok @@ V_Ct (C_nat n) + | Literal_timestamp i -> ok @@ V_Ct (C_timestamp i) + | Literal_string s -> ok @@ V_Ct (C_string s) + | Literal_bytes s -> ok @@ V_Ct (C_bytes s) + | Literal_mutez t -> ok @@ V_Ct (C_mutez t) + | Literal_address s -> ok @@ V_Ct (C_address s) + | Literal_signature s -> ok @@ V_Ct (C_signature s) + | Literal_key s -> ok @@ V_Ct (C_key s) + | Literal_key_hash s -> ok @@ V_Ct (C_key_hash s) + | Literal_chain_id s -> ok @@ V_Ct (C_key_hash s) + | Literal_operation o -> ok @@ V_Ct (C_operation o) + | Literal_void -> simple_fail "iguess ?" + +and eval : Ast_typed.expression -> env -> value result + = fun term env -> + match term.expression_content with + | E_application ({expr1 = f; expr2 = args}) -> ( + let%bind f' = eval f env in + match f' with + | V_Func_val (arg_names, body, f_env) -> + let%bind args' = eval args 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; result;} -> + ok @@ V_Func_val (binder,result,env) + | E_let_in { let_binder; rhs; let_result; _} -> + let%bind rhs' = eval rhs env in + eval let_result (Env.extend env (let_binder,rhs')) + | E_map kvlist | E_big_map kvlist -> + let%bind kvlist' = bind_map_list + (fun kv -> bind_map_pair (fun (el:Ast_typed.expression) -> eval el env) kv) + kvlist in + ok @@ V_Map kvlist' + | E_list expl -> + let%bind expl' = bind_map_list + (fun (exp:Ast_typed.expression) -> eval exp env) + expl in + ok @@ V_List expl' + | E_set expl -> + let%bind expl' = bind_map_list + (fun (exp:Ast_typed.expression) -> eval exp env) + (List.sort_uniq compare expl) + in + ok @@ V_Set 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.expression)) -> + let%bind v' = eval v env in + ok (label,v')) + (LMap.to_kv_list recmap) in + ok @@ V_Record (LMap.of_list lv') + | E_record_accessor { expr ; label} -> ( + let%bind record' = eval expr 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 ; path ; update} -> ( + let%bind record' = eval record env in + match record' with + | V_Record recmap -> + if LMap.mem path recmap then + let%bind field' = eval update env in + ok @@ V_Record (LMap.add path field' recmap) + else + simple_fail "field l does not exist in record" + | _ -> simple_fail "this expression isn't a record" + ) + | E_constant {cons_name ; arguments} -> ( + let%bind operands' = bind_map_list + (fun (ae:Ast_typed.expression) -> eval ae env) + arguments in + apply_operator cons_name operands' + ) + | E_constructor { constructor = Constructor c ; element } -> + let%bind v' = eval element env in + ok @@ V_Construct (c,v') + | E_matching { matchee ; cases} -> ( + let%bind e' = eval matchee env in + match cases, e' with + | Match_list cases , V_List [] -> + eval cases.match_nil 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 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 env' + | Match_bool cases , V_Ct (C_bool true) -> + eval cases.match_true env + | Match_bool cases , V_Ct (C_bool false) -> + eval cases.match_false 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 env' + | Match_option cases, V_Construct ("None" , V_Ct C_unit) -> + eval cases.match_none env + | _ -> simple_fail "not yet supported case" + (* ((ctor,name),body) *) + ) + | E_look_up _ | E_loop _ -> + 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 (exp_name, exp , _ , _)) = Location.unwrap el in + let%bind v = + (*TODO This TRY-CATCH is here until we properly implement effects*) + try + eval exp top_env + with Temporary_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 exp_name)^" = "^(Ligo_interpreter.PP.pp_value v) in + let top_env' = Env.extend top_env (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/passes/operators/operators.ml b/src/passes/operators/operators.ml index 7c3bd7318..ed77a7f64 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -181,6 +181,7 @@ module Simplify = struct | "Bytes.sub" -> ok C_SLICE | "Set.mem" -> ok C_SET_MEM + | "Set.iter" -> ok C_SET_ITER | "Set.empty" -> ok C_SET_EMPTY | "Set.literal" -> ok C_SET_LITERAL | "Set.add" -> ok C_SET_ADD diff --git a/src/stages/ligo_interpreter/PP.ml b/src/stages/ligo_interpreter/PP.ml new file mode 100644 index 000000000..b47b4993a --- /dev/null +++ b/src/stages/ligo_interpreter/PP.ml @@ -0,0 +1,39 @@ +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 (C_address s) -> Format.asprintf "\"%s\" : address" s + | 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/combinators.ml b/src/stages/ligo_interpreter/combinators.ml new file mode 100644 index 000000000..d01ef460f --- /dev/null +++ b/src/stages/ligo_interpreter/combinators.ml @@ -0,0 +1,34 @@ +open Trace +open Types + +let v_pair : value * value -> value = + fun (a,b) -> V_Record (LMap.of_list [(Label "0", a) ; (Label "1",b)]) + +let v_bool : bool -> value = + fun b -> V_Ct (C_bool b) + +let v_unit : unit -> value = + fun () -> V_Ct (C_unit) + +let v_some : value -> value = + fun v -> V_Construct ("Some", v) + +let v_none : unit -> value = + fun () -> V_Construct ("None", v_unit ()) + +let extract_pair : value -> (value * value) result = + fun p -> + let err = simple_error "value is not a pair" in + ( match p with + | V_Record lmap -> + let%bind fst = trace_option err @@ + LMap.find_opt (Label "0") lmap in + let%bind snd = trace_option err @@ + LMap.find_opt (Label "1") lmap in + ok (fst,snd) + | _ -> fail err ) + +let is_true : value -> bool result = + fun b -> match b with + | V_Ct (C_bool b) -> ok b + | _ -> simple_fail "value is not a bool" 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..60ca6311e --- /dev/null +++ b/src/stages/ligo_interpreter/ligo_interpreter.ml @@ -0,0 +1,4 @@ +module Types = Types +module PP = PP +module Environment = Environment +module Combinators = Combinators \ 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..4cd8e79ad --- /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 Temporary_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..90fe2bcbf --- /dev/null +++ b/src/test/contracts/interpret_test.mligo @@ -0,0 +1,238 @@ +let lambda_call = + let a = 3 in + let foo = fun (i : int) -> i * i in + foo (a + 1) + +let higher_order1 = + let a = 2 in + let foo = 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 = fun (i:int) -> + let b = 2 in + let bar = fun (i:int) -> i + a + b + in bar i + in foo 1 + +let higher_order3 = + let foo = fun (i:int) -> i + 1 in + let bar = fun (f:int->int) (i:int) -> (f i) + 1 in + let baz : (int -> int ) = bar foo in + baz 3 + +let higher_order4 = + let a = 3 in + let foo = fun (i : int) -> a + i in + let bar: (int -> int) = fun (i : int) -> foo i in + bar 2 + +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) + +let var_neg = + let a = 2 in + -a + +let sizes = + let a = [ 1 ; 2 ; 3 ; 4 ; 5 ] in + let b = "12345" in + let c = Set.literal [ 1 ; 2 ; 3 ; 4 ; 5 ] in + let d = Map.literal [ (1,1) ; (2,2) ; (3,3) ] in + let e = 0xFFFF in + (List.size a, String.size b, Set.size c, Map.size d, Bytes.size e) + +let modi = 3 mod 2 + +let fold_while = + let aux : int -> bool * int = fun (i:int) -> + if i < 10 then continue (i + 1) else stop i in + (Loop.fold_while aux 20, Loop.fold_while aux 0) + +let assertion_pass = + assert (1=1) + +let assertion_fail = + assert (1=2) + +let lit_address = ("KT1ThEdxfUcWUwqsdergy3QnbCWGHSUHeHJq" : address) + +let map_finds = + let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] in + Map.find_opt "two" m + +let map_finds_fail = + let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] in + Map.find "four" m + +let map_empty = + ((Map.empty : (int,int) map) , (Map.literal [] : (int,int) map)) + +let m = Map.literal [ ("one" , 1) ; ("two" , 2) ; ("three" , 3) ] + +let map_fold = + let aux = fun (i: int * (string * int)) -> i.0 + i.1.1 in + Map.fold aux m (-2) + +let map_iter = + let aux = fun (i: string * int) -> if (i.1=12) then failwith "never" else () in + Map.iter aux m + +let map_map = + let aux = fun (i: string * int) -> i.1 + (String.size i.0) in + Map.map aux m + +let map_mem = (Map.mem "one" m , Map.mem "four" m) + +let map_remove = (Map.remove "one" m, Map.remove "four" m) + +let map_update = ( + Map.update "one" (Some(1)) (Map.literal [ "one", 2 ]), + Map.update "one" (None : int option) (Map.literal [ "one", 1]), + Map.update "one" (None : int option) (Map.literal []:(string,int) map), + Map.update "one" (Some(1)) (Map.literal []:(string,int) map) +) + +let s = Set.literal [ 1 ; 2 ; 3 ] + +let set_add = ( + Set.add 1 s, + Set.add 4 s, + Set.add 1 (Set.literal [] : int set) +) + +let set_iter_fail = + let aux = fun (i:int) -> if i = 1 then failwith "set_iter_fail" else () in + Set.iter aux (Set.literal [1 ; 2 ; 3]) + +let set_mem = ( + Set.mem 1 s, + Set.mem 4 s, + Set.mem 1 (Set.literal [] : int set) +) 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 []