From daa1c18573779ae889f30bb1f6ac1d0dbdc668a4 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Mon, 25 May 2020 14:07:43 -0500 Subject: [PATCH 01/32] Strip type annotations from some instructions --- src/bin/expect_tests/contract_tests.ml | 4 +- .../13-self_michelson/self_michelson.ml | 51 +++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 6de7be144..c52e7c366 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -7,7 +7,7 @@ let bad_contract basename = let%expect_test _ = run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ; - [%expect {| 1700 bytes |}] ; + [%expect {| 1668 bytes |}] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; [%expect {| 995 bytes |}] ; @@ -276,7 +276,7 @@ let%expect_test _ = DIG 7 ; DUP ; DUG 8 ; - NONE (pair (address %card_owner) (nat %card_pattern)) ; + NONE (pair address nat) ; SWAP ; UPDATE ; DIG 2 ; diff --git a/src/passes/13-self_michelson/self_michelson.ml b/src/passes/13-self_michelson/self_michelson.ml index 8a3291204..729bd454a 100644 --- a/src/passes/13-self_michelson/self_michelson.ml +++ b/src/passes/13-self_michelson/self_michelson.ml @@ -422,6 +422,56 @@ let rec opt_combine_drops (x : michelson) : michelson = Prim (l, p, List.map opt_combine_drops args, annot) | x -> x +(* number of type arguments for (some) prims, where we will strip + annots *) +let prim_type_args : prim -> int option = function + | I_NONE -> Some 1 + | I_NIL -> Some 1 + | I_EMPTY_SET -> Some 1 + | I_EMPTY_MAP -> Some 2 + | I_EMPTY_BIG_MAP -> Some 2 + | I_LAMBDA -> Some 2 + (* _not_ I_CONTRACT! annot is important there *) + (* but could include I_SELF, maybe? *) + | _ -> None + +(* returns (List.firstn n xs, List.skipn n xs) as in Coq (OCaml stdlib + does not have those...) *) +let split_at (n : int) (xs : 'a list) : 'a list * 'a list = + let rec aux n acc = + if n <= 0 + then acc + else + let (bef, aft) = acc in + match aft with + | [] -> acc + | x :: aft -> + aux (n - 1) (x :: bef, aft) in + let (bef, aft) = aux n ([], xs) in + (List.rev bef, aft) + +(* strip annots from type arguments in some instructions *) +let rec opt_strip_annots (x : michelson) : michelson = + match x with + | Seq (l, args) -> + let args = List.map opt_strip_annots args in + Seq (l, args) + | Prim (l, p, args, annot) -> + begin + match prim_type_args p with + | Some n -> + let (type_args, args) = split_at n args in + (* strip annots from type args *) + let type_args = List.map strip_annots type_args in + (* recur into remaining args *) + let args = List.map opt_strip_annots args in + Prim (l, p, type_args @ args, annot) + | None -> + let args = List.map opt_strip_annots args in + Prim (l, p, args, annot) + end + | x -> x + let optimize : michelson -> michelson = fun x -> let x = use_lambda_instr x in @@ -436,4 +486,5 @@ let optimize : michelson -> michelson = ] in let x = iterate_optimizer (sequence_optimizers optimizers) x in let x = opt_combine_drops x in + let x = opt_strip_annots x in x From 1fe9b29732d4cf0f545f735c737d09dac50b1741 Mon Sep 17 00:00:00 2001 From: Alexander Bantyev Date: Tue, 26 May 2020 20:29:11 +0300 Subject: [PATCH 02/32] Always show coverage reports --- .gitlab-ci.yml | 1 + nix/ocaml-overlay.nix | 5 +---- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 8681301a7..6ff438506 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -63,6 +63,7 @@ test: - /^.*-run-dev$/ script: - nix-build nix -A ligo-coverage + - cat result/share/coverage-all - cp -Lr --no-preserve=mode,ownership,timestamps result/share/coverage . artifacts: paths: diff --git a/nix/ocaml-overlay.nix b/nix/ocaml-overlay.nix index b44cfdcef..8dd971e79 100644 --- a/nix/ocaml-overlay.nix +++ b/nix/ocaml-overlay.nix @@ -133,19 +133,16 @@ in { echo "Coverage:" BISECT_ENABLE=yes dune runtest --force bisect-ppx-report html -o $out/share/coverage/all --title="LIGO overall test coverage" - bisect-ppx-report summary --per-file + bisect-ppx-report summary --per-file > $out/share/coverage-all echo "Test coverage:" BISECT_ENABLE=yes dune runtest src/test --force bisect-ppx-report html -o $out/share/coverage/ligo --title="LIGO test coverage" - bisect-ppx-report summary --per-file echo "Doc coverage:" BISECT_ENABLE=yes dune build @doc-test --force bisect-ppx-report html -o $out/share/coverage/docs --title="LIGO doc coverage" - bisect-ppx-report summary --per-file echo "CLI test coverage:" BISECT_ENABLE=yes dune runtest src/bin/expect_tests bisect-ppx-report html -o $out/share/coverage/cli --title="CLI test coverage" - bisect-ppx-report summary --per-file ''; installPhase = "true"; }); From d53d4829b5dd783f7e22456074ddf1332769f3d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jev=20Bj=C3=B6rsell?= Date: Wed, 27 May 2020 14:58:10 +0000 Subject: [PATCH 03/32] Website/records docs --- .../docs/language-basics/maps-records.md | 47 +++++++++++-------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/gitlab-pages/docs/language-basics/maps-records.md b/gitlab-pages/docs/language-basics/maps-records.md index 5c27f1395..81a26f1be 100644 --- a/gitlab-pages/docs/language-basics/maps-records.md +++ b/gitlab-pages/docs/language-basics/maps-records.md @@ -5,12 +5,12 @@ title: Records and Maps import Syntax from '@theme/Syntax'; -So far we have seen pretty basic data types. LIGO also offers more +So far, we have seen pretty basic data types. LIGO also offers more complex built-in constructs, such as *records* and *maps*. ## Records -Records are one way data of different types can be packed into a +Records are one-way data of different types can be packed into a single type. A record is made of a set of *fields*, which are made of a *field name* and a *field type*. Given a value of a record type, the value bound to a field can be accessed by giving its field name to a @@ -18,8 +18,6 @@ special operator (`.`). Let us first consider and example of record type declaration. - - ```pascaligo group=records1 @@ -55,10 +53,8 @@ type user = { - And here is how a record value is defined: - ```pascaligo group=records1 @@ -142,7 +138,7 @@ points on a plane. In PascaLIGO, the shape of that expression is ` with `. -The record variable is the record to update and the +The record variable is the record to update, and the record value is the update itself. ```pascaligo group=records2 @@ -160,13 +156,13 @@ following command of the shell: ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_update.ligo -translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])" +xy_translate "(record [x=2;y=3;z=1], record [dx=3;dy=4])" # Outputs: {z = 1 , y = 7 , x = 5} ``` You have to understand that `p` has not been changed by the functional -update: a namless new version of it has been created and returned by -the blockless function. +update: a nameless new version of it has been created and returned by +the block-less function. @@ -186,6 +182,7 @@ let xy_translate (p, vec : point * vector) : point = You can call the function `xy_translate` defined above by running the following command of the shell: + ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_update.mligo @@ -218,6 +215,7 @@ let xy_translate = ((p, vec) : (point, vector)) : point => You can call the function `xy_translate` defined above by running the following command of the shell: + ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_update.religo @@ -326,12 +324,21 @@ let change_color_preference = (account : account, color : color): account => Note that all the records in the path will get updated. In this example that's `account` and `preferences`. +You can call the function `change_color_preference` defined above by running the +following command: + +```shell +ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_nested_update.ligo +change_color_preference "(record [id=1001; preferences=record [color=Blue; other=1]], Green)" +# Outputs: record[id -> 1001 , preferences -> record[color -> Green(unit) , other -> 1]] +``` + ### Record Patches Another way to understand what it means to update a record value is to -make sure that any further reference to the value afterwards will +make sure that any further reference to the value afterward will exhibit the modification. This is called a `patch` and this is only possible in PascaLIGO, because a patch is an *instruction*, therefore we can only use it in a block. Similarly to a *functional update*, a @@ -355,6 +362,7 @@ function xy_translate (var p : point; const vec : vector) : point is You can call the function `xy_translate` defined above by running the following command of the shell: + ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_patch.ligo @@ -378,6 +386,7 @@ function xy_translate (var p : point; const vec : vector) : point is You can call the new function `xy_translate` defined above by running the following command of the shell: + ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_patch2.ligo @@ -401,6 +410,7 @@ function xy_translate (var p : point; const vec : vector) : point is You can call the new function `xy_translate` defined above by running the following command of the shell: + ```shell ligo run-function gitlab-pages/docs/language-basics/src/maps-records/record_simu.ligo @@ -425,8 +435,6 @@ sense. Here is how a custom map from addresses to a pair of integers is defined. - - ```pascaligo group=maps @@ -680,8 +688,8 @@ let assign = (m : register) : register => (("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), Some ((4,9)), m); ``` -Notice the optional value `Some (4,9)` instead of `(4,9)`. If we had -use `None` instead, that would have meant that the binding is removed. +Notice the optional value `Some (4,9)` instead of `(4,9)`. If we used +`None` instead that would have meant that the binding is removed. As a particular case, we can only add a key and its associated value. @@ -693,7 +701,6 @@ let add = (m : register) : register => - To remove a binding from a map, we need its key. @@ -748,8 +755,8 @@ There are three kinds of functional iterations over LIGO maps: the The first, the *iterated operation*, is an iteration over the map with no return value: its only use is to produce side-effects. This can be -useful if for example you would like to check that each value inside -of a map is within a certain range, and fail with an error otherwise. +useful if, for example you would like to check that each value inside +of a map is within a certain range and fail with an error otherwise. The predefined functional iterator implementing the iterated operation over maps is called `Map.iter`. In the following example, the register @@ -985,7 +992,7 @@ let moves : register = (("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), (0,3))] ``` -The predefind function `Big_map.literal` constructs a big map from a +The predefined function `Big_map.literal` constructs a big map from a list of key-value pairs `(, )`. Note also the semicolon separating individual map entries. The annotated value `(" value>" : address)` means that we cast a string into an address. @@ -1000,7 +1007,7 @@ let moves : register = ("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address, (0,3))]); ``` -The predefind function `Big_map.literal` constructs a big map from a +The predefined function `Big_map.literal` constructs a big map from a list of key-value pairs `(, )`. Note also the semicolon separating individual map entries. The annotated value `(" value>" : address)` means that we cast a string into an address. From 294e048affda48ed4a0f9341a9e429c5cd69d70c Mon Sep 17 00:00:00 2001 From: Gabriel ALFOUR Date: Wed, 27 May 2020 23:01:07 +0200 Subject: [PATCH 04/32] remove environments from the ast --- src/bin/cli.ml | 10 +-- src/passes/10-interpreter/interpreter.ml | 32 +++++---- src/passes/10-transpiler/transpiler.ml | 26 ++++---- src/passes/10-transpiler/untranspiler.ml | 10 +-- src/passes/8-typer-new/typer.ml | 4 +- src/passes/8-typer-old/typer.ml | 19 +++--- src/passes/9-self_ast_typed/helpers.ml | 66 ++++++++++--------- .../9-self_ast_typed/michelson_layout.ml | 12 ++-- src/passes/9-self_ast_typed/self_ast_typed.ml | 4 +- src/stages/4-ast_typed/PP.ml | 4 +- src/stages/4-ast_typed/ast.ml | 23 ++++--- src/stages/4-ast_typed/ast_typed.ml | 2 + src/stages/4-ast_typed/combinators.ml | 11 ++-- src/stages/4-ast_typed/combinators.mli | 37 +++++------ .../4-ast_typed/combinators_environment.ml | 28 ++++---- .../4-ast_typed/combinators_environment.mli | 30 ++++----- .../4-ast_typed/compute_environment.ml} | 51 ++++++-------- src/stages/4-ast_typed/misc.ml | 21 +++--- src/stages/4-ast_typed/misc.mli | 2 +- src/stages/4-ast_typed/misc_smart.ml | 27 +++----- src/stages/typesystem/misc.ml | 15 ++--- src/test/test_helpers.ml | 4 +- 22 files changed, 217 insertions(+), 221 deletions(-) rename src/{passes/9-self_ast_typed/recompute_environment.ml => stages/4-ast_typed/compute_environment.ml} (76%) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index c7798eeb3..0dc4df7cb 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -263,7 +263,7 @@ let compile_parameter = let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in - let env = Ast_typed.program_environment typed_prg in + let env = Ast_typed.program_environment Environment.default typed_prg in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) Compile.Of_michelson.build_contract michelson_prg in @@ -290,7 +290,7 @@ let interpret = | Some init_file -> let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in - let env = Ast_typed.program_environment typed_prg in + let env = Ast_typed.program_environment Environment.default typed_prg in ok (mini_c_prg,state,env) | None -> ok ([],Typer.Solver.initial_state,Environment.default) in @@ -332,7 +332,7 @@ let compile_storage = let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in - let env = Ast_typed.program_environment typed_prg in + let env = Ast_typed.program_environment Environment.default typed_prg in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) Compile.Of_michelson.build_contract michelson_prg in @@ -356,7 +356,7 @@ let dry_run = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in - let env = Ast_typed.program_environment typed_prg in + let env = Ast_typed.program_environment Environment.default typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in let%bind (_contract: Tezos_utils.Michelson.michelson) = @@ -386,7 +386,7 @@ let run_function = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format = toplevel ~display_format @@ let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in - let env = Ast_typed.program_environment typed_prg in + let env = Ast_typed.program_environment Environment.default typed_prg in let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index c76b464f7..31867602b 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -368,19 +368,23 @@ and eval : Ast_typed.expression -> env -> value result 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 {binder; expr ; inline=_ ; _}) = Location.unwrap el in - let%bind v = - (*TODO This TRY-CATCH is here until we properly implement effects*) - try - eval expr 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 binder)^" = "^(Ligo_interpreter.PP.pp_value v) in - let top_env' = Env.extend top_env (binder, v) in - ok @@ (pp',top_env') - ) + let aux (pp,top_env) el = + match Location.unwrap el with + | Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _} -> + let%bind v = + (*TODO This TRY-CATCH is here until we properly implement effects*) + try + eval expr 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 binder)^" = "^(Ligo_interpreter.PP.pp_value v) in + let top_env' = Env.extend top_env (binder, v) in + ok @@ (pp',top_env') + | Ast_typed.Declaration_type _ -> + ok (pp , top_env) + in + let%bind (res,_) = bind_fold_list aux ("",Env.empty_env) prg in ok @@ res diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 756c984d3..01698f300 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -374,8 +374,8 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_unit -> D_unit | Literal_void -> D_none -and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele -> - transpile_type ele.type_value +(* and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele -> + * transpile_type ele.type_value *) and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t -> let%bind map_tv = get_t_sum t in @@ -397,11 +397,11 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result')) | E_literal l -> return @@ E_literal (transpile_literal l) | E_variable name -> ( - let%bind ele = - trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ - AST.Environment.get_opt name ae.environment in - let%bind tv = transpile_environment_element_type ele in - return ~tv @@ E_variable (name) + (* let%bind ele = + * trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ + * AST.Environment.get_opt name ae.environment in + * let%bind tv = transpile_environment_element_type tv in *) + return @@ E_variable (name) ) | E_application {lamb; args} -> let%bind a = transpile_annotated_expression lamb in @@ -759,19 +759,21 @@ and transpile_recursive {fun_name; fun_type; lambda} = let body = Expression.make (E_iterator (C_LOOP_LEFT, ((lambda.binder, loop_type),body), expr)) output_type in ok @@ Expression.make (E_closure {binder;body}) fun_type -let transpile_declaration env (d:AST.declaration) : toplevel_statement result = +let transpile_declaration env (d:AST.declaration) : toplevel_statement option result = match d with - | Declaration_constant { binder ; expr ; inline ; post_env=_ } -> + | Declaration_constant { binder ; expr ; inline } -> let%bind expression = transpile_annotated_expression expr in let tv = Combinators.Expression.get_type expression in let env' = Environment.add (binder, tv) env in - ok @@ ((binder, inline, expression), environment_wrap env env') + ok @@ Some ((binder, inline, expression), environment_wrap env env') + | _ -> ok None let transpile_program (lst : AST.program) : program result = let aux (prev:(toplevel_statement list * Environment.t) result) cur = let%bind (hds, env) = prev in - let%bind ((_, env') as cur') = transpile_declaration env cur in - ok (hds @ [ cur' ], env'.post_environment) + match%bind transpile_declaration env cur with + | Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment) + | None -> ok (hds , env) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index a6864bff9..5f68cddd5 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -42,19 +42,19 @@ open Errors let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result = let open! AST in - let return e = ok (make_a_e_empty e t) in + let return e = ok (make_e e t) in match t.type_content with | T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> ( let%bind b = trace_strong (wrong_mini_c_value "bool" v) @@ get_bool v in - return (e_bool b Environment.empty) + return (e_bool b) ) | t when (compare t (t_bool ()).type_content) = 0-> ( let%bind b = trace_strong (wrong_mini_c_value "bool" v) @@ get_bool v in - return (e_bool b Environment.empty) + return (e_bool b) ) | T_constant type_constant -> ( match type_constant with @@ -152,10 +152,10 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul trace_strong (wrong_mini_c_value "option" v) @@ get_option v in match opt with - | None -> ok (e_a_empty_none o) + | None -> ok (e_a_none o) | Some s -> let%bind s' = untranspile s o in - ok (e_a_empty_some s') + ok (e_a_some s') ) | TC_map {k=k_ty;v=v_ty}-> ( let%bind map = diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 36fa997fe..13a7def62 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -29,7 +29,7 @@ let rec type_declaration env state : I.declaration -> (environment * O.typer_sta trace (constant_declaration_error binder expression tv'_opt) @@ type_expression env state expression in let post_env = Environment.add_ez_declaration binder expr env in - ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline ; post_env} )) + ok (post_env, state' , Some (O.Declaration_constant { binder ; expr ; inline} )) ) and type_match : environment -> O.typer_state -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> (O.matching_expr * O.typer_state) result = @@ -196,7 +196,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression let%bind new_state = aggregate_constraints state constraints in let tv = t_variable type_name () in let location = ae.location in - let expr' = make_e ~location expr tv e in + let expr' = make_e ~location expr tv in ok @@ (expr' , new_state) in let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in let main_error = diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 17af76c00..a60edf107 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -504,17 +504,17 @@ let rec type_program (p:I.program) : (O.program * O.typer_state) result = ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration option) result = function - | Declaration_type (type_name , type_expression) -> - let%bind tv = evaluate_type env type_expression in - let env' = Environment.add_type (type_name) tv env in - ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) + | Declaration_type (type_binder , type_expr) -> + let%bind tv = evaluate_type env type_expr in + let env' = Environment.add_type (type_binder) tv env in + ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_type { type_binder ; type_expr = tv } )) | Declaration_constant (binder , tv_opt , inline, expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind expr = trace (constant_declaration_error binder expression tv'_opt) @@ type_expression' ?tv_opt:tv'_opt env expression in let post_env = Environment.add_ez_declaration binder expr env in - ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline ; post_env})) + ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline})) ) and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result = @@ -674,6 +674,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression = fun e _placeholder_for_state_of_new_typer ?tv_opt ae -> let%bind res = type_expression' e ?tv_opt ae in ok (res, (Solver.placeholder_for_state_of_new_typer ())) + and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression -> O.expression result = fun e ?tv_opt ae -> let module L = Logger.Stateful() in let return expr tv = @@ -682,7 +683,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression | None -> ok () | Some tv' -> O.assert_type_expression_eq (tv' , tv) in let location = ae.location in - ok @@ make_e ~location expr tv e in + ok @@ make_e ~location expr tv in let main_error = let title () = "typing expression" in let content () = "" in @@ -736,7 +737,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression generic_try (bad_record_access property ae prev.type_expression ae.location) @@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in let location = ae.location in - ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv e + ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv in let%bind ae = trace (simple_info "accessing") @@ aux e' path in @@ -832,7 +833,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let e' = Environment.add_ez_binder lname input_type e in let%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in let output_type = body.type_expression in - let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in + let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in let lst' = [lambda'; v_col; v_initr] in let tv_lst = List.map get_type_expression lst' in let%bind (opname', tv) = @@ -853,7 +854,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let e' = Environment.add_ez_binder lname input_type e in let%bind body = type_expression' e' result in let output_type = body.type_expression in - let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) e' in + let lambda' = make_e (E_lambda {binder = lname ; result=body}) (t_function input_type output_type ()) in let lst' = [lambda';v_initr] in let tv_lst = List.map get_type_expression lst' in let%bind (opname',tv) = type_constant opname tv_lst tv_opt in diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index f42d1ea37..a63a2893a 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -156,10 +156,11 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> and map_program : mapper -> program -> program result = fun m p -> let aux = fun (x : declaration) -> match x with - | Declaration_constant {binder; expr ; inline ; post_env} -> ( + | Declaration_constant {binder; expr ; inline} -> ( let%bind expr = map_expression m expr in - ok (Declaration_constant {binder; expr ; inline ; post_env}) - ) + ok (Declaration_constant {binder; expr ; inline}) + ) + | Declaration_type t -> ok (Declaration_type t) in bind_map_list (bind_map_location aux) p @@ -246,11 +247,15 @@ and fold_map_cases : 'a . 'a fold_mapper -> 'a -> matching_expr -> ('a * matchin and fold_map_program : 'a . 'a fold_mapper -> 'a -> program -> ('a * program) result = fun m init p -> let aux = fun (acc,acc_prg) (x : declaration Location.wrap) -> match Location.unwrap x with - | Declaration_constant {binder ; expr ; inline ; post_env} -> ( + | Declaration_constant {binder ; expr ; inline} -> ( let%bind (acc', expr) = fold_map_expression m acc expr in - let wrap_content = Declaration_constant {binder ; expr ; inline ; post_env} in + let wrap_content = Declaration_constant {binder ; expr ; inline} in ok (acc', List.append acc_prg [{x with wrap_content}]) ) + | Declaration_type t -> ( + let wrap_content = Declaration_type t in + ok (acc, List.append acc_prg [{x with wrap_content}]) + ) in bind_fold_list aux (init,[]) p @@ -298,30 +303,31 @@ type contract_type = { } let fetch_contract_type : string -> program -> contract_type result = fun main_fname program -> - let main_decl = List.rev @@ List.filter - (fun declt -> - let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in - String.equal (Var.to_name binder) main_fname - ) - program + let aux declt = match Location.unwrap declt with + | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) -> + if String.equal (Var.to_name binder) main_fname + then Some p + else None + | Declaration_type _ -> None in - match main_decl with - | (hd::_) -> ( - let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in - match expr.type_expression.type_content with - | T_arrow {type1 ; type2} -> ( - match type1.type_content , type2.type_content with - | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> - let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in - let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in - let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@ - Ast_typed.assert_t_list_operation listop in - let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@ - Ast_typed.assert_type_expression_eq (storage,storage') in - (* TODO: on storage/parameter : assert_storable, assert_passable ? *) - ok { parameter ; storage } - | _ -> fail @@ Errors.bad_contract_io main_fname expr - ) - | _ -> fail @@ Errors.bad_contract_io main_fname expr + let main_decl_opt = List.find_map aux @@ List.rev program in + let%bind main_decl = + trace_option (simple_error ("Entrypoint '"^main_fname^"' does not exist")) @@ + main_decl_opt + in + let { binder=_ ; expr ; inline=_ } = main_decl in + match expr.type_expression.type_content with + | T_arrow {type1 ; type2} -> ( + match type1.type_content , type2.type_content with + | T_record tin , T_record tout when (is_tuple_lmap tin) && (is_tuple_lmap tout) -> + let%bind (parameter,storage) = Ast_typed.Helpers.get_pair tin in + let%bind (listop,storage') = Ast_typed.Helpers.get_pair tout in + let%bind () = trace_strong (Errors.expected_list_operation main_fname listop expr) @@ + Ast_typed.assert_t_list_operation listop in + let%bind () = trace_strong (Errors.expected_same main_fname storage storage' expr) @@ + Ast_typed.assert_type_expression_eq (storage,storage') in + (* TODO: on storage/parameter : assert_storable, assert_passable ? *) + ok { parameter ; storage } + | _ -> fail @@ Errors.bad_contract_io main_fname expr ) - | [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist") + | _ -> fail @@ Errors.bad_contract_io main_fname expr diff --git a/src/passes/9-self_ast_typed/michelson_layout.ml b/src/passes/9-self_ast_typed/michelson_layout.ml index 2211715b9..ce59c0898 100644 --- a/src/passes/9-self_ast_typed/michelson_layout.ml +++ b/src/passes/9-self_ast_typed/michelson_layout.ml @@ -13,25 +13,25 @@ let accessor (record:expression) (path:label) (t:type_expression) = { expression_content = E_record_accessor {record; path} ; location = Location.generated ; type_expression = t ; - environment = record.environment } + } let constructor (constructor:constructor') (element:expression) (t:type_expression) = { expression_content = E_constructor { constructor ; element } ; location = Location.generated ; type_expression = t ; - environment = element.environment } + } let match_var (t:type_expression) = { expression_content = E_variable (Var.of_name "x") ; location = Location.generated ; type_expression = t ; - environment = Environment.add_ez_binder (Var.of_name "x") t Environment.empty} + } let matching (e:expression) matchee cases = { expression_content = E_matching {matchee ; cases}; location = Location.generated ; type_expression = e.type_expression ; - environment = e.environment } + } let rec descend_types s lmap i = if i > 0 then @@ -105,7 +105,7 @@ let rec to_right_comb_record let exp = { expression_content = E_record_accessor {record = prev ; path = label } ; location = Location.generated ; type_expression = field_type ; - environment = prev.environment } in + } in let conv_map' = LMap.add (Label "0") exp conv_map in LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map' @@ -275,4 +275,4 @@ let peephole_expression : expression -> expression result = fun e -> return match_expr.expression_content | _ -> return e.expression_content ) - | _ as e -> return e \ No newline at end of file + | _ as e -> return e diff --git a/src/passes/9-self_ast_typed/self_ast_typed.ml b/src/passes/9-self_ast_typed/self_ast_typed.ml index 77b50ce9c..35821b3d6 100644 --- a/src/passes/9-self_ast_typed/self_ast_typed.ml +++ b/src/passes/9-self_ast_typed/self_ast_typed.ml @@ -13,8 +13,8 @@ let contract_passes = [ let all_program program = let all_p = List.map Helpers.map_program all_passes in let%bind program' = bind_chain all_p program in - let program'' = Recompute_environment.program Environment.default program' in - ok program'' + (* let program'' = Recompute_environment.program Environment.default program' in *) + ok program' let all_expression = let all_p = List.map Helpers.map_expression all_passes in diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 5691cac65..08e2f778c 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -326,8 +326,10 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit = let declaration ppf (d : declaration) = match d with - | Declaration_constant {binder; expr; inline; post_env=_} -> + | Declaration_constant {binder; expr; inline} -> fprintf ppf "const %a = %a%a" expression_variable binder expression expr option_inline inline + | Declaration_type {type_binder; type_expr} -> + fprintf ppf "type %a = %a" type_variable type_binder type_expression type_expr let program ppf (p : program) = fprintf ppf "@[%a@]" diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index e85aace9d..8a846aa61 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -272,31 +272,30 @@ and declaration_loc = declaration location_wrap and program = declaration_loc list +(* A Declaration_constant is described by + * a name + a type-annotated expression + * a boolean indicating whether it should be inlined + * the environment before the declaration (the original environment) + * the environment after the declaration (i.e. with that new declaration added to the original environment). *) and declaration_constant = { binder : expression_variable ; expr : expression ; inline : bool ; - post_env : environment ; + } + +and declaration_type = { + type_binder : type_variable ; + type_expr : type_expression ; } and declaration = - (* A Declaration_constant is described by - * a name + a type-annotated expression - * a boolean indicating whether it should be inlined - * the environment before the declaration (the original environment) - * the environment after the declaration (i.e. with that new declaration added to the original environment). *) | Declaration_constant of declaration_constant - (* - | Declaration_type of (type_variable * type_expression) - | Declaration_constant of (named_expression * (environment * environment)) - *) -(* | Macro_declaration of macro_declaration *) + | Declaration_type of declaration_type and expression = { expression_content: expression_content ; location: location ; type_expression: type_expression ; - environment: environment ; } and map_kv = { diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml index e78dc9188..bd70790a7 100644 --- a/src/stages/4-ast_typed/ast_typed.ml +++ b/src/stages/4-ast_typed/ast_typed.ml @@ -15,3 +15,5 @@ module Helpers = Helpers include Types include Misc include Combinators + +let program_environment env program = fst (Compute_environment.program env program) diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index e7959cec7..b423da73d 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -24,10 +24,9 @@ module Errors = struct end let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core} -let make_e ?(location = Location.generated) expression_content type_expression environment = { +let make_e ?(location = Location.generated) expression_content type_expression = { expression_content ; type_expression ; - environment ; location ; } let make_n_t type_name type_value = { type_name ; type_value } @@ -83,7 +82,6 @@ let t_shallow_closure param result ?loc ?s () : type_expression = make_t ?loc (T let get_type_expression (x:expression) = x.type_expression let get_type' (x:type_expression) = x.type_content -let get_environment (x:expression) = x.environment let get_expression (x:expression) = x.expression_content let get_lambda e : _ result = match e.expression_content with @@ -330,13 +328,13 @@ let e_let_in let_binder inline rhs let_result = E_let_in { let_binder ; rhs ; le let e_constructor constructor element: expression_content = E_constructor {constructor;element} -let e_bool b env : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit()) env) +let e_bool b : expression_content = e_constructor (Constructor (string_of_bool b)) (make_e (e_unit ())(t_unit())) let e_a_unit = make_e (e_unit ()) (t_unit ()) let e_a_int n = make_e (e_int n) (t_int ()) let e_a_nat n = make_e (e_nat n) (t_nat ()) let e_a_mutez n = make_e (e_mutez n) (t_mutez ()) -let e_a_bool b = fun env -> make_e (e_bool b env) (t_bool ()) env +let e_a_bool b = make_e (e_bool b) (t_bool ()) let e_a_string s = make_e (e_string s) (t_string ()) let e_a_address s = make_e (e_address s) (t_address ()) let e_a_pair a b = make_e (e_pair a b) @@ -381,7 +379,8 @@ let get_a_record_accessor = fun t -> let get_declaration_by_name : program -> string -> declaration result = fun p name -> let aux : declaration -> bool = fun declaration -> match declaration with - | Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ } -> binder = Var.of_name name + | Declaration_constant { binder ; expr=_ ; inline=_ } -> binder = Var.of_name name + | Declaration_type _ -> false in trace_option (Errors.declaration_not_found name ()) @@ List.find_opt aux @@ List.map Location.unwrap p diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index 192939c72..f4fe615b2 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -3,7 +3,7 @@ open Types val make_n_t : type_variable -> type_expression -> named_type_content val make_t : ?loc:Location.t -> type_content -> S.type_expression option -> type_expression -val make_e : ?location:Location.t -> expression_content -> type_expression -> environment -> expression +val make_e : ?location:Location.t -> expression_content -> type_expression -> expression val t_bool : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_string : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression @@ -38,7 +38,6 @@ val t_function : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.t val t_shallow_closure : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val get_type_expression : expression -> type_expression val get_type' : type_expression -> type_content -val get_environment : expression -> environment val get_expression : expression -> expression_content val get_lambda : expression -> lambda result val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) result @@ -119,7 +118,7 @@ val e_unit : unit -> expression_content val e_int : Z.t -> expression_content val e_nat : Z.t -> expression_content val e_mutez : Z.t -> expression_content -val e_bool : bool -> environment -> expression_content +val e_bool : bool -> expression_content val e_string : ligo_string -> expression_content val e_bytes : bytes -> expression_content val e_timestamp : Z.t -> expression_content @@ -135,22 +134,22 @@ val e_application : expression -> expression -> expression_content val e_variable : expression_variable -> expression_content val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content -val e_a_unit : environment -> expression -val e_a_int : Z.t -> environment -> expression -val e_a_nat : Z.t -> environment -> expression -val e_a_mutez : Z.t -> environment -> expression -val e_a_bool : bool -> environment -> expression -val e_a_string : ligo_string -> environment -> expression -val e_a_address : string -> environment -> expression -val e_a_pair : expression -> expression -> environment -> expression -val e_a_some : expression -> environment -> expression -val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression -val e_a_none : type_expression -> environment -> expression -val e_a_record : expression label_map -> environment -> expression -val e_a_application : expression -> expression -> environment -> expression -val e_a_variable : expression_variable -> type_expression -> environment -> expression -val ez_e_a_record : ( label * expression ) list -> environment -> expression -val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> expression +val e_a_unit : expression +val e_a_int : Z.t -> expression +val e_a_nat : Z.t -> expression +val e_a_mutez : Z.t -> expression +val e_a_bool : bool -> expression +val e_a_string : ligo_string -> expression +val e_a_address : string -> expression +val e_a_pair : expression -> expression -> expression +val e_a_some : expression -> expression +val e_a_lambda : lambda -> type_expression -> type_expression -> expression +val e_a_none : type_expression -> expression +val e_a_record : expression label_map -> expression +val e_a_application : expression -> expression -> expression +val e_a_variable : expression_variable -> type_expression -> expression +val ez_e_a_record : ( label * expression ) list -> expression +val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression val get_a_int : expression -> Z.t result val get_a_unit : expression -> unit result diff --git a/src/stages/4-ast_typed/combinators_environment.ml b/src/stages/4-ast_typed/combinators_environment.ml index 78e11ad9a..401d9b4c4 100644 --- a/src/stages/4-ast_typed/combinators_environment.ml +++ b/src/stages/4-ast_typed/combinators_environment.ml @@ -1,21 +1,21 @@ open Types open Combinators -let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty +(* let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty *) -let e_a_empty_unit = e_a_unit Environment.empty -let e_a_empty_int n = e_a_int n Environment.empty -let e_a_empty_nat n = e_a_nat n Environment.empty -let e_a_empty_mutez n = e_a_mutez n Environment.empty -let e_a_empty_bool b = e_a_bool b Environment.empty -let e_a_empty_string s = e_a_string s Environment.empty -let e_a_empty_address s = e_a_address s Environment.empty -let e_a_empty_pair a b = e_a_pair a b Environment.empty -let e_a_empty_some s = e_a_some s Environment.empty -let e_a_empty_none t = e_a_none t Environment.empty -let e_a_empty_record r = e_a_record r Environment.empty -let ez_e_a_empty_record r = ez_e_a_record r Environment.empty -let e_a_empty_lambda l i o = e_a_lambda l i o Environment.empty +(* let e_a_empty_unit = e_a_unit Environment.empty + * let e_a_empty_int n = e_a_int n Environment.empty + * let e_a_empty_nat n = e_a_nat n Environment.empty + * let e_a_empty_mutez n = e_a_mutez n Environment.empty + * let e_a_empty_bool b = e_a_bool b Environment.empty + * let e_a_empty_string s = e_a_string s Environment.empty + * let e_a_empty_address s = e_a_address s Environment.empty + * let e_a_empty_pair a b = e_a_pair a b Environment.empty + * let e_a_empty_some s = e_a_some s Environment.empty + * let e_a_empty_none t = e_a_none t Environment.empty + * let e_a_empty_record r = e_a_record r Environment.empty + * let ez_e_a_empty_record r = ez_e_a_record r Environment.empty + * let e_a_empty_lambda l i o = e_a_lambda l i o Environment.empty *) open Environment diff --git a/src/stages/4-ast_typed/combinators_environment.mli b/src/stages/4-ast_typed/combinators_environment.mli index 64b325975..9e5e86441 100644 --- a/src/stages/4-ast_typed/combinators_environment.mli +++ b/src/stages/4-ast_typed/combinators_environment.mli @@ -1,19 +1,19 @@ open Types -val make_a_e_empty : expression_content -> type_expression -> expression - -val e_a_empty_unit : expression -val e_a_empty_int : Z.t -> expression -val e_a_empty_nat : Z.t -> expression -val e_a_empty_mutez : Z.t -> expression -val e_a_empty_bool : bool -> expression -val e_a_empty_string : ligo_string -> expression -val e_a_empty_address : string -> expression -val e_a_empty_pair : expression -> expression -> expression -val e_a_empty_some : expression -> expression -val e_a_empty_none : type_expression -> expression -val e_a_empty_record : expression label_map -> expression -val ez_e_a_empty_record : ( label * expression ) list -> expression -val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression +(* val make_a_e_empty : expression_content -> type_expression -> expression + * + * val e_a_empty_unit : expression + * val e_a_empty_int : Z.t -> expression + * val e_a_empty_nat : Z.t -> expression + * val e_a_empty_mutez : Z.t -> expression + * val e_a_empty_bool : bool -> expression + * val e_a_empty_string : ligo_string -> expression + * val e_a_empty_address : string -> expression + * val e_a_empty_pair : expression -> expression -> expression + * val e_a_empty_some : expression -> expression + * val e_a_empty_none : type_expression -> expression + * val e_a_empty_record : expression label_map -> expression + * val ez_e_a_empty_record : ( label * expression ) list -> expression + * val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression *) val env_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment diff --git a/src/passes/9-self_ast_typed/recompute_environment.ml b/src/stages/4-ast_typed/compute_environment.ml similarity index 76% rename from src/passes/9-self_ast_typed/recompute_environment.ml rename to src/stages/4-ast_typed/compute_environment.ml index bed098190..ce4013a28 100644 --- a/src/passes/9-self_ast_typed/recompute_environment.ml +++ b/src/stages/4-ast_typed/compute_environment.ml @@ -1,23 +1,9 @@ -open Ast_typed - -(* - During the modifications of the passes on `Ast_typed`, the binding - environments are not kept in sync. To palliate this, this module - recomputes them from scratch. -*) - -(* - This module is very coupled to `typer.ml`. Given environments are - not used until the next pass, it makes sense to split this into - its own separate pass. This pass would go from `Ast_typed` without - environments to `Ast_typed` with embedded environments. -*) +open Types let rec expression : environment -> expression -> expression = fun env expr -> (* Standard helper functions to help with the fold *) - let return ?(env' = env) content = { + let return content = { expr with - environment = env' ; expression_content = content ; } in let return_id = return expr.expression_content in @@ -90,7 +76,7 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs -> let match_cons = let mc = c.match_cons in let env_hd = Environment.add_ez_binder mc.hd mc.tv env in - let env_tl = Environment.add_ez_binder mc.tl (t_list mc.tv ()) env_hd in + let env_tl = Environment.add_ez_binder mc.tl (Combinators.t_list mc.tv ()) env_hd in let body = self ~env':env_tl mc.body in { mc with body } in @@ -139,24 +125,27 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs -> return @@ Match_variant { c with cases } ) -let program : environment -> program -> program = fun init_env prog -> +let program : environment -> program -> environment * program = fun init_env prog -> (* BAD We take the old type environment and add it to the current value environment because type declarations are removed in the typer. They should be added back. *) - let merge old_env re_env = { - expression_environment = re_env.expression_environment ; - type_environment = old_env.type_environment ; - } in let aux (pre_env , rev_decls) decl_wrapped = - let (Declaration_constant c) = Location.unwrap decl_wrapped in - let expr = expression pre_env c.expr in - let post_env = Environment.add_ez_declaration c.binder expr pre_env in - let post_env' = merge c.post_env post_env in - let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in - let decl_wrapped' = { decl_wrapped with wrap_content } in - (post_env , decl_wrapped' :: rev_decls) + match Location.unwrap decl_wrapped with + | Declaration_constant c -> ( + let expr = expression pre_env c.expr in + let post_env = Environment.add_ez_declaration c.binder expr pre_env in + let wrap_content = Declaration_constant { c with expr } in + let decl_wrapped' = { decl_wrapped with wrap_content } in + (post_env , decl_wrapped' :: rev_decls) + ) + | Declaration_type t -> ( + let post_env = Environment.add_type t.type_binder t.type_expr pre_env in + let wrap_content = Declaration_type t in + let decl_wrapped' = { decl_wrapped with wrap_content } in + (post_env , decl_wrapped' :: rev_decls) + ) in - let (_last_env , rev_decls) = List.fold_left aux (init_env , []) prog in - List.rev rev_decls + let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in + (last_env , List.rev rev_decls) diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index a3df9718f..81daf803e 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -511,18 +511,21 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err : let get_entry (lst : program) (name : string) : expression result = trace_option (Errors.missing_entry_point name) @@ - let aux x = - let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in - if Var.equal binder (Var.of_name name) - then Some expr - else None + let aux x = + match Location.unwrap x with + | Declaration_constant { binder ; expr ; inline=_ } -> ( + if Var.equal binder (Var.of_name name) + then Some expr + else None + ) + | Declaration_type _ -> None in List.find_map aux lst -let program_environment (program : program) : environment = - let last_declaration = Location.unwrap List.(hd @@ rev program) in - match last_declaration with - | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env +(* let program_environment (program : program) : environment = + * let last_declaration = Location.unwrap List.(hd @@ rev program) in + * match last_declaration with + * | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env *) let equal_variables a b : bool = match a.expression_content, b.expression_content with diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index ae0bb692f..c6c18e221 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -70,7 +70,7 @@ val assert_literal_eq : ( literal * literal ) -> unit result *) val get_entry : program -> string -> expression result -val program_environment : program -> environment +(* val program_environment : program -> environment *) val p_constant : constant_tag -> p_ctor_args -> type_value val c_equation : type_value -> type_value -> string -> type_constraint diff --git a/src/stages/4-ast_typed/misc_smart.ml b/src/stages/4-ast_typed/misc_smart.ml index a09ed2acc..d62665149 100644 --- a/src/stages/4-ast_typed/misc_smart.ml +++ b/src/stages/4-ast_typed/misc_smart.ml @@ -8,8 +8,9 @@ let program_to_main : program -> string -> lambda result = fun p s -> let%bind (main , input_type , _) = let pred = fun d -> match d with - | Declaration_constant { binder; expr; inline=_ ; post_env=_ } when binder = Var.of_name s -> Some expr + | Declaration_constant { binder; expr; inline=_ } when binder = Var.of_name s -> Some expr | Declaration_constant _ -> None + | Declaration_type _ -> None in let%bind main = trace_option (simple_error "no main with given name") @@ @@ -20,16 +21,11 @@ let program_to_main : program -> string -> lambda result = fun p s -> | _ -> simple_fail "program main isn't a function" in ok (main , input_ty , output_ty) in - let env = - let aux = fun _ d -> - match d with - | Declaration_constant {binder=_ ; expr= _ ; inline=_ ; post_env } -> post_env in - List.fold_left aux Environment.empty (List.map Location.unwrap p) in let binder = Var.of_name "@contract_input" in let result = - let input_expr = e_a_variable binder input_type env in - let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) env in - e_a_application main_expr input_expr env in + let input_expr = e_a_variable binder input_type in + let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in + e_a_application main_expr input_expr in ok { binder ; result ; @@ -46,8 +42,8 @@ module Captured_variables = struct let of_list : expression_variable list -> bindings = fun x -> x let rec expression : bindings -> expression -> bindings result = fun b e -> - expression_content b e.environment e.expression_content - and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec -> + expression_content b e.expression_content + and expression_content : bindings -> expression_content -> bindings result = fun b ec -> let self = expression b in match ec with | E_lambda l -> ok @@ Free_variables.lambda empty l @@ -56,12 +52,7 @@ module Captured_variables = struct let%bind lst' = bind_map_list self arguments in ok @@ unions lst' | E_variable name -> ( - let%bind env_element = - trace_option (simple_error "missing var in env") @@ - Environment.get_opt name env in - match env_element.definition with - | ED_binder -> ok empty - | ED_declaration {expr=_ ; free_variables=_} -> simple_fail "todo" + if mem name b then ok empty else ok (singleton name) ) | E_application {lamb;args} -> let%bind lst' = bind_map_list self [ lamb ; args ] in @@ -84,7 +75,7 @@ module Captured_variables = struct expression b' li.let_result | E_recursive r -> let b' = union (singleton r.fun_name) b in - expression_content b' env @@ E_lambda r.lambda + expression_content b' @@ E_lambda r.lambda and matching_variant_case : (bindings -> expression -> bindings result) -> bindings -> matching_content_case -> bindings result = fun f b { constructor=_ ; pattern ; body } -> f (union (singleton pattern) b) body diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index d7662698a..336f8cdf2 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -195,20 +195,19 @@ module Substitution = struct let%bind cases = s_matching_expr ~substs cases in ok @@ T.E_matching {matchee;cases} - and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; environment; location } -> + and s_expression : T.expression w = fun ~(substs:substs) { expression_content; type_expression; location } -> let%bind expression_content = s_expression_content ~substs expression_content in let%bind type_expr = s_type_expression ~substs type_expression in - let%bind environment = s_environment ~substs environment in let location = location in - ok T.{ expression_content;type_expression=type_expr; environment; location } + ok T.{ expression_content;type_expression=type_expr; location } and s_declaration : T.declaration w = fun ~substs -> function - Ast_typed.Declaration_constant {binder ; expr ; inline ; post_env} -> - let%bind binder = s_variable ~substs binder in - let%bind expr = s_expression ~substs expr in - let%bind post_env = s_environment ~substs post_env in - ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env} + | Ast_typed.Declaration_constant {binder ; expr ; inline} -> + let%bind binder = s_variable ~substs binder in + let%bind expr = s_expression ~substs expr in + ok @@ Ast_typed.Declaration_constant {binder; expr; inline} + | Declaration_type t -> ok (Ast_typed.Declaration_type t) and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d -> Trace.bind_map_location (s_declaration ~substs) d diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index ded88c33b..adeb5649a 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -38,7 +38,7 @@ open Ast_imperative let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result = let%bind code = - let env = Ast_typed.program_environment program in + let env = Ast_typed.program_environment Environment.default program in let%bind sugar = Compile.Of_imperative.compile_expression payload in let%bind core = Compile.Of_sugar.compile_expression sugar in @@ -89,7 +89,7 @@ let typed_program_with_imperative_input_to_michelson (program: Ast_typed.program) (entry_point: string) (input: Ast_imperative.expression) : Compiler.compiled_expression result = Printexc.record_backtrace true; - let env = Ast_typed.program_environment program in + let env = Ast_typed.program_environment Environment.default program in let state = Typer.Solver.initial_state in let%bind sugar = Compile.Of_imperative.compile_expression input in let%bind core = Compile.Of_sugar.compile_expression sugar in From fcfa2944c625ee220dbf26c62af67acab9b3edc2 Mon Sep 17 00:00:00 2001 From: Alexander Bantyev Date: Thu, 28 May 2020 00:21:00 +0300 Subject: [PATCH 05/32] Disable webide-e2e tests --- .gitlab-ci.yml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6ff438506..903873eb5 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -69,7 +69,8 @@ test: paths: - coverage -webide-e2e: +# Strange race conditions, disable for now +.webide-e2e: extends: .nix only: - merge_requests From e6614160563839e7a0ed1791e4c291e25db3982f Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Thu, 28 May 2020 10:53:54 +0200 Subject: [PATCH 06/32] review 1 --- src/environment/bool.ml | 6 ++++- src/passes/10-transpiler/transpiler.ml | 12 +++------ src/passes/8-typer-old/typer.ml | 10 +++----- src/passes/8-typer-old/typer.mli | 2 +- src/passes/9-self_ast_typed/self_ast_typed.ml | 1 - src/stages/4-ast_typed/ast_typed.ml | 1 - .../4-ast_typed/combinators_environment.ml | 25 ------------------- .../4-ast_typed/combinators_environment.mli | 19 -------------- src/stages/4-ast_typed/environment.ml | 5 +++- src/stages/4-ast_typed/environment.mli | 1 + src/stages/4-ast_typed/misc.ml | 5 ---- src/stages/4-ast_typed/misc.mli | 1 - src/test/typer_tests.ml | 4 +-- 13 files changed, 20 insertions(+), 72 deletions(-) delete mode 100644 src/stages/4-ast_typed/combinators_environment.ml delete mode 100644 src/stages/4-ast_typed/combinators_environment.mli diff --git a/src/environment/bool.ml b/src/environment/bool.ml index 611c84dfd..d3fea07eb 100644 --- a/src/environment/bool.ml +++ b/src/environment/bool.ml @@ -1,4 +1,8 @@ open Ast_typed open Stage_common.Constant -let environment = env_sum_type ~type_name:t_bool @@ [(Constructor "true",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0});(Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1})] +let environment = Ast_typed.Environment.add_ez_sum_type ~type_name:t_bool @@ + [ + (Constructor "true" ,{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=0}); + (Constructor "false",{ctor_type=t_unit ();michelson_annotation=None;ctor_decl_pos=1}); + ] diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 01698f300..5ea4ea43f 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -374,9 +374,6 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with | Literal_unit -> D_unit | Literal_void -> D_none -(* and transpile_environment_element_type : AST.environment_element -> type_expression result = fun ele -> - * transpile_type ele.type_value *) - and tree_of_sum : AST.type_expression -> (AST.constructor' * AST.type_expression) Append_tree.t result = fun t -> let%bind map_tv = get_t_sum t in let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in @@ -397,10 +394,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result')) | E_literal l -> return @@ E_literal (transpile_literal l) | E_variable name -> ( - (* let%bind ele = - * trace_option (corner_case ~loc:__LOC__ "name not in environment") @@ - * AST.Environment.get_opt name ae.environment in - * let%bind tv = transpile_environment_element_type tv in *) return @@ E_variable (name) ) | E_application {lamb; args} -> @@ -441,7 +434,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return ~tv ae ) | E_record m -> ( - (*list_of_lmap to record_to_list*) let node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in let aux a b : expression result = let%bind a = a in @@ -779,7 +771,9 @@ let transpile_program (lst : AST.program) : program result = ok statements (* check whether the storage contains a big_map, if yes, check that - it appears on the left hand side of a pair *) + it appears on the left hand side of a pair + TODO : checking should appears in check_pass. +*) let check_storage f ty loc : (anon_function * _) result = let rec aux (t:type_expression) on_big_map = match t.type_content with diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index a60edf107..ca2a123a7 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -494,27 +494,25 @@ let rec type_program (p:I.program) : (O.program * O.typer_state) result = let%bind ed' = (bind_map_location (type_declaration e (Solver.placeholder_for_state_of_new_typer ()))) d in let loc : 'a . 'a Location.wrap -> _ -> _ = fun x v -> Location.wrap ~loc:x.location v in let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in - match d' with - | None -> ok (e', acc) - | Some d' -> ok (e', loc ed' d' :: acc) + ok (e', loc ed' d' :: acc) in let%bind (_, lst) = trace (fun () -> program_error p ()) @@ bind_fold_list aux (DEnv.default, []) p in ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) -and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration option) result = function +and type_declaration env (_placeholder_for_state_of_new_typer : O.typer_state) : I.declaration -> (environment * O.typer_state * O.declaration) result = function | Declaration_type (type_binder , type_expr) -> let%bind tv = evaluate_type env type_expr in let env' = Environment.add_type (type_binder) tv env in - ok (env', (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_type { type_binder ; type_expr = tv } )) + ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } )) | Declaration_constant (binder , tv_opt , inline, expression) -> ( let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind expr = trace (constant_declaration_error binder expression tv'_opt) @@ type_expression' ?tv_opt:tv'_opt env expression in let post_env = Environment.add_ez_declaration binder expr env in - ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , Some (O.Declaration_constant { binder ; expr ; inline})) + ok (post_env, (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_constant { binder ; expr ; inline})) ) and type_match : (environment -> I.expression -> O.expression result) -> environment -> O.type_expression -> I.matching_expr -> I.expression -> Location.t -> O.matching_expr result = diff --git a/src/passes/8-typer-old/typer.mli b/src/passes/8-typer-old/typer.mli index ff7009a8c..531a6b751 100644 --- a/src/passes/8-typer-old/typer.mli +++ b/src/passes/8-typer-old/typer.mli @@ -39,7 +39,7 @@ module Errors : sig end val type_program : I.program -> (O.program * O.typer_state) result -val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration option) result +val type_declaration : environment -> O.typer_state -> I.declaration -> (environment * O.typer_state * O.declaration) result (* val type_match : (environment -> 'i -> 'o result) -> environment -> O.type_value -> 'i I.matching -> I.expression -> Location.t -> 'o O.matching result *) val evaluate_type : environment -> I.type_expression -> O.type_expression result val type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result diff --git a/src/passes/9-self_ast_typed/self_ast_typed.ml b/src/passes/9-self_ast_typed/self_ast_typed.ml index 35821b3d6..442564638 100644 --- a/src/passes/9-self_ast_typed/self_ast_typed.ml +++ b/src/passes/9-self_ast_typed/self_ast_typed.ml @@ -13,7 +13,6 @@ let contract_passes = [ let all_program program = let all_p = List.map Helpers.map_program all_passes in let%bind program' = bind_chain all_p program in - (* let program'' = Recompute_environment.program Environment.default program' in *) ok program' let all_expression = diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml index bd70790a7..9a1250ecc 100644 --- a/src/stages/4-ast_typed/ast_typed.ml +++ b/src/stages/4-ast_typed/ast_typed.ml @@ -4,7 +4,6 @@ module PP = PP module PP_generic = PP_generic module Combinators = struct include Combinators - include Combinators_environment end module Misc = struct include Misc diff --git a/src/stages/4-ast_typed/combinators_environment.ml b/src/stages/4-ast_typed/combinators_environment.ml deleted file mode 100644 index 401d9b4c4..000000000 --- a/src/stages/4-ast_typed/combinators_environment.ml +++ /dev/null @@ -1,25 +0,0 @@ -open Types -open Combinators - -(* let make_a_e_empty expression type_annotation = make_e expression type_annotation Environment.empty *) - -(* let e_a_empty_unit = e_a_unit Environment.empty - * let e_a_empty_int n = e_a_int n Environment.empty - * let e_a_empty_nat n = e_a_nat n Environment.empty - * let e_a_empty_mutez n = e_a_mutez n Environment.empty - * let e_a_empty_bool b = e_a_bool b Environment.empty - * let e_a_empty_string s = e_a_string s Environment.empty - * let e_a_empty_address s = e_a_address s Environment.empty - * let e_a_empty_pair a b = e_a_pair a b Environment.empty - * let e_a_empty_some s = e_a_some s Environment.empty - * let e_a_empty_none t = e_a_none t Environment.empty - * let e_a_empty_record r = e_a_record r Environment.empty - * let ez_e_a_empty_record r = ez_e_a_record r Environment.empty - * let e_a_empty_lambda l i o = e_a_lambda l i o Environment.empty *) - -open Environment - -let env_sum_type ?(env = empty) - ?(type_name = Var.of_name "a_sum_type") - (lst : (constructor' * ctor_content) list) = - add_type type_name (make_t_ez_sum lst) env diff --git a/src/stages/4-ast_typed/combinators_environment.mli b/src/stages/4-ast_typed/combinators_environment.mli deleted file mode 100644 index 9e5e86441..000000000 --- a/src/stages/4-ast_typed/combinators_environment.mli +++ /dev/null @@ -1,19 +0,0 @@ -open Types - -(* val make_a_e_empty : expression_content -> type_expression -> expression - * - * val e_a_empty_unit : expression - * val e_a_empty_int : Z.t -> expression - * val e_a_empty_nat : Z.t -> expression - * val e_a_empty_mutez : Z.t -> expression - * val e_a_empty_bool : bool -> expression - * val e_a_empty_string : ligo_string -> expression - * val e_a_empty_address : string -> expression - * val e_a_empty_pair : expression -> expression -> expression - * val e_a_empty_some : expression -> expression - * val e_a_empty_none : type_expression -> expression - * val e_a_empty_record : expression label_map -> expression - * val ez_e_a_empty_record : ( label * expression ) list -> expression - * val e_a_empty_lambda : lambda -> type_expression -> type_expression -> expression *) - -val env_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment diff --git a/src/stages/4-ast_typed/environment.ml b/src/stages/4-ast_typed/environment.ml index 30e59ebab..0b9457466 100644 --- a/src/stages/4-ast_typed/environment.ml +++ b/src/stages/4-ast_typed/environment.ml @@ -38,6 +38,9 @@ let add_ez_binder : expression_variable -> type_expression -> t -> t = fun k v e let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e -> add_expr k (make_element_declaration e ae) e +let add_ez_sum_type ?(env = empty) ?(type_name = Var.of_name "a_sum_type") (lst : (constructor' * ctor_content) list) = + add_type type_name (make_t_ez_sum lst) env + let convert_constructor' (S.Constructor c) = Constructor c let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *) @@ -76,4 +79,4 @@ module PP = struct expr_environment (get_expr_environment e) type_environment (get_type_environment e) -end \ No newline at end of file +end diff --git a/src/stages/4-ast_typed/environment.mli b/src/stages/4-ast_typed/environment.mli index 6b3fb52e2..d73279d85 100644 --- a/src/stages/4-ast_typed/environment.mli +++ b/src/stages/4-ast_typed/environment.mli @@ -11,6 +11,7 @@ val get_opt : expression_variable -> t -> element option val get_type_opt : type_variable -> t -> type_expression option val get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option +val add_ez_sum_type : ?env:environment -> ?type_name:type_variable -> (constructor' * ctor_content) list -> environment module PP : sig open Format diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 81daf803e..7528dab2e 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -522,11 +522,6 @@ let get_entry (lst : program) (name : string) : expression result = in List.find_map aux lst -(* let program_environment (program : program) : environment = - * let last_declaration = Location.unwrap List.(hd @@ rev program) in - * match last_declaration with - * | Declaration_constant { binder=_ ; expr=_ ; inline=_ ; post_env } -> post_env *) - let equal_variables a b : bool = match a.expression_content, b.expression_content with | E_variable a, E_variable b -> Var.equal a b diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index c6c18e221..561458303 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -70,7 +70,6 @@ val assert_literal_eq : ( literal * literal ) -> unit result *) val get_entry : program -> string -> expression result -(* val program_environment : program -> environment *) val p_constant : constant_tag -> p_ctor_args -> type_value val c_equation : type_value -> type_value -> string -> type_constraint diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index e4ea12df5..c26e690ba 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -34,7 +34,7 @@ module TestExpressions = struct module I = Simplified.Combinators module O = Typed.Combinators - module E = O + module E = Typed.Environment let unit () : unit result = test_expression I.(e_unit ()) O.(t_unit ()) let int () : unit result = test_expression I.(e_int (Z.of_int 32)) O.(t_int ()) @@ -59,7 +59,7 @@ module TestExpressions = struct (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0}); (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ] in test_expression - ~env:(E.env_sum_type variant_foo_bar) + ~env:(E.add_ez_sum_type variant_foo_bar) I.(e_constructor "foo" (e_int (Z.of_int 32))) O.(make_t_ez_sum variant_foo_bar) From b7da8e3fd459ea00555e997a77270e72919fcd64 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 29 May 2020 15:29:16 +0200 Subject: [PATCH 07/32] remove unecessary files --- src/stages/1-ast_imperative/ast_imperative.ml | 1 - src/stages/1-ast_imperative/misc.ml | 353 ------------------ src/stages/1-ast_imperative/misc.mli | 20 - src/stages/2-ast_sugar/ast_sugar.ml | 1 - src/stages/2-ast_sugar/misc.ml | 350 ----------------- src/stages/2-ast_sugar/misc.mli | 20 - 6 files changed, 745 deletions(-) delete mode 100644 src/stages/1-ast_imperative/misc.ml delete mode 100644 src/stages/1-ast_imperative/misc.mli delete mode 100644 src/stages/2-ast_sugar/misc.ml delete mode 100644 src/stages/2-ast_sugar/misc.mli diff --git a/src/stages/1-ast_imperative/ast_imperative.ml b/src/stages/1-ast_imperative/ast_imperative.ml index e9614490a..7fa34e677 100644 --- a/src/stages/1-ast_imperative/ast_imperative.ml +++ b/src/stages/1-ast_imperative/ast_imperative.ml @@ -3,6 +3,5 @@ include Types (* include Misc *) include Combinators module Types = Types -module Misc = Misc module PP=PP module Combinators = Combinators diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml deleted file mode 100644 index cf27a497d..000000000 --- a/src/stages/1-ast_imperative/misc.ml +++ /dev/null @@ -1,353 +0,0 @@ -open Trace -open Types - -open Stage_common.Helpers -module Errors = struct - let different_literals_because_different_types name a b () = - let title () = "literals have different types: " ^ name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let different_literals name a b () = - let title () = name ^ " are different" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let error_uncomparable_literals name a b () = - let title () = name ^ " are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () -end -open Errors - -let assert_literal_eq (a, b : literal * literal) : unit result = - match (a, b) with - | Literal_int a, Literal_int b when a = b -> ok () - | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b - | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b - | Literal_nat a, Literal_nat b when a = b -> ok () - | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b - | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b - | Literal_timestamp a, Literal_timestamp b when a = b -> ok () - | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b - | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_mutez a, Literal_mutez b when a = b -> ok () - | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b - | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b - | Literal_string a, Literal_string b when a = b -> ok () - | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b - | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b - | Literal_bytes a, Literal_bytes b when a = b -> ok () - | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b - | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b - | Literal_void, Literal_void -> ok () - | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b - | Literal_unit, Literal_unit -> ok () - | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b - | Literal_address a, Literal_address b when a = b -> ok () - | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b - | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b - | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b - | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b - | Literal_signature a, Literal_signature b when a = b -> ok () - | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b - | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b - | Literal_key a, Literal_key b when a = b -> ok () - | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b - | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b - | Literal_key_hash a, Literal_key_hash b when a = b -> ok () - | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b - | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b - | Literal_chain_id a, Literal_chain_id b when a = b -> ok () - | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b - | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b - -let rec assert_value_eq (a, b: (expression * expression )) : unit result = - Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b; - let error_content () = - Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b - in - trace (fun () -> error (thunk "not equal") error_content ()) @@ - match (a.expression_content , b.expression_content) with - | E_literal a , E_literal b -> - assert_literal_eq (a, b) - | E_literal _ , _ -> - simple_fail "comparing a literal with not a literal" - | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( - let%bind lst = - generic_try (simple_error "constants with different number of elements") - (fun () -> List.combine ca.arguments cb.arguments) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () - ) - | E_constant _ , E_constant _ -> - simple_fail "different constants" - | E_constant _ , _ -> - let error_content () = - Format.asprintf "%a vs %a" - PP.expression a - PP.expression b - in - fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) - - | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> ( - let%bind _eq = assert_value_eq (ca.element, cb.element) in - ok () - ) - | E_constructor _, E_constructor _ -> - simple_fail "different constructors" - | E_constructor _, _ -> - simple_fail "comparing constructor with other expression" - - - | E_record sma, E_record smb -> ( - let aux _ a b = - match a, b with - | Some a, Some b -> Some (assert_value_eq (a, b)) - | _ -> Some (simple_fail "different record keys") - in - let%bind _all = bind_lmap @@ LMap.merge aux sma smb in - ok () - ) - | E_record _, _ -> - simple_fail "comparing record with other expression" - - | E_record_update ura, E_record_update urb -> - let _ = - generic_try (simple_error "Updating different record") @@ - fun () -> assert_value_eq (ura.record, urb.record) in - let aux (Label a,Label b) = - assert (String.equal a b) - in - let () = aux (ura.path, urb.path) in - let%bind () = assert_value_eq (ura.update,urb.update) in - ok () - | E_record_update _, _ -> - simple_fail "comparing record update with other expression" - - | E_tuple lsta, E_tuple lstb -> ( - let%bind lst = - generic_try (simple_error "tuples with different number of elements") - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () - ) - | E_tuple _, _ -> - simple_fail "comparing tuple with other expression" - - | E_tuple_update uta, E_tuple_update utb -> - let _ = - generic_try (simple_error "Updating different tuple") @@ - fun () -> assert_value_eq (uta.tuple, utb.tuple) in - let () = assert (uta.path == utb.path) in - let%bind () = assert_value_eq (uta.update,utb.update) in - ok () - | E_tuple_update _, _ -> - simple_fail "comparing tuple update with other expression" - - | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( - let%bind lst = generic_try (simple_error "maps of different lengths") - (fun () -> - let lsta' = List.sort compare lsta in - let lstb' = List.sort compare lstb in - List.combine lsta' lstb') in - let aux = fun ((ka, va), (kb, vb)) -> - let%bind _ = assert_value_eq (ka, kb) in - let%bind _ = assert_value_eq (va, vb) in - ok () in - let%bind _all = bind_map_list aux lst in - ok () - ) - | (E_map _ | E_big_map _), _ -> - simple_fail "comparing map with other expression" - - | E_list lsta, E_list lstb -> ( - let%bind lst = - generic_try (simple_error "list of different lengths") - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_list _, _ -> - simple_fail "comparing list with other expression" - - | E_set lsta, E_set lstb -> ( - let lsta' = List.sort (compare) lsta in - let lstb' = List.sort (compare) lstb in - let%bind lst = - generic_try (simple_error "set of different lengths") - (fun () -> List.combine lsta' lstb') in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_set _, _ -> - simple_fail "comparing set with other expression" - - | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) - | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) - | (E_variable _, _) | (E_lambda _, _) - | (E_application _, _) | (E_let_in _, _) - | (E_recursive _,_) - | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) - | (E_matching _, _) | (E_cond _, _) - | (E_sequence _, _) | (E_skip, _) - | (E_assign _, _) - | (E_for _, _) | (E_for_each _, _) - | (E_while _, _) -> simple_fail "comparing not a value" - -let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) - -(* module Rename = struct - * open Trace - * - * module Type = struct - * (\* Type renaming, not needed. Yet. *\) - * end - * - * module Value = struct - * type renaming = string * (string * access_path) (\* src -> dst *\) - * type renamings = renaming list - * let filter (r:renamings) (s:string) : renamings = - * List.filter (fun (x, _) -> not (x = s)) r - * let filters (r:renamings) (ss:string list) : renamings = - * List.filter (fun (x, _) -> not (List.mem x ss)) r - * - * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = - * match i with - * | I_assignment ({name;annotated_expression = e} as a) -> ( - * match List.assoc_opt name r with - * | None -> - * let%bind annotated_expression = rename_annotated_expression (filter r name) e in - * ok (I_assignment {a with annotated_expression}) - * | Some (name', lst) -> ( - * let%bind annotated_expression = rename_annotated_expression r e in - * match lst with - * | [] -> ok (I_assignment {name = name' ; annotated_expression}) - * | lst -> - * let (hds, tl) = - * let open List in - * let r = rev lst in - * rev @@ tl r, hd r - * in - * let%bind tl' = match tl with - * | Access_record n -> ok n - * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in - * ok (I_record_patch (name', hds, [tl', annotated_expression])) - * ) - * ) - * | I_skip -> ok I_skip - * | I_fail e -> - * let%bind e' = rename_annotated_expression r e in - * ok (I_fail e') - * | I_loop (cond, body) -> - * let%bind cond' = rename_annotated_expression r cond in - * let%bind body' = rename_block r body in - * ok (I_loop (cond', body')) - * | I_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_block r m in - * ok (I_matching (ae', m')) - * | I_record_patch (v, path, lst) -> - * let aux (x, y) = - * let%bind y' = rename_annotated_expression (filter r v) y in - * ok (x, y') in - * let%bind lst' = bind_map_list aux lst in - * match List.assoc_opt v r with - * | None -> ( - * ok (I_record_patch (v, path, lst')) - * ) - * | Some (v', path') -> ( - * ok (I_record_patch (v', path' @ path, lst')) - * ) - * and rename_block (r:renamings) (bl:block) : block result = - * bind_map_list (rename_instruction r) bl - * - * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = - * fun f r m -> - * match m with - * | Match_bool { match_true = mt ; match_false = mf } -> - * let%bind match_true = f r mt in - * let%bind match_false = f r mf in - * ok (Match_bool {match_true ; match_false}) - * | Match_option { match_none = mn ; match_some = (some, ms) } -> - * let%bind match_none = f r mn in - * let%bind ms' = f (filter r some) ms in - * ok (Match_option {match_none ; match_some = (some, ms')}) - * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> - * let%bind match_nil = f r mn in - * let%bind mc' = f (filters r [hd;tl]) mc in - * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) - * | Match_tuple (lst, body) -> - * let%bind body' = f (filters r lst) body in - * ok (Match_tuple (lst, body')) - * - * and rename_matching_instruction = fun x -> rename_matching rename_block x - * - * and rename_matching_expr = fun x -> rename_matching rename_expression x - * - * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = - * let%bind expression = rename_expression r ae.expression in - * ok {ae with expression} - * - * and rename_expression : renamings -> expression -> expression result = fun r e -> - * match e with - * | E_literal _ as l -> ok l - * | E_constant (name, lst) -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_constant (name, lst')) - * | E_constructor (name, ae) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_constructor (name, ae')) - * | E_variable v -> ( - * match List.assoc_opt v r with - * | None -> ok (E_variable v) - * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) - * ) - * | E_lambda ({binder;body;result} as l) -> - * let r' = filter r binder in - * let%bind body = rename_block r' body in - * let%bind result = rename_annotated_expression r' result in - * ok (E_lambda {l with body ; result}) - * | E_application (f, arg) -> - * let%bind f' = rename_annotated_expression r f in - * let%bind arg' = rename_annotated_expression r arg in - * ok (E_application (f', arg')) - * | E_tuple lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_tuple lst') - * | E_accessor (ae, p) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_accessor (ae', p)) - * | E_record sm -> - * let%bind sm' = bind_smap - * @@ SMap.map (rename_annotated_expression r) sm in - * ok (E_record sm') - * | E_map m -> - * let%bind m' = bind_map_list - * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in - * ok (E_map m') - * | E_list lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_list lst') - * | E_look_up m -> - * let%bind m' = bind_map_pair (rename_annotated_expression r) m in - * ok (E_look_up m') - * | E_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_annotated_expression r m in - * ok (E_matching (ae', m')) - * end - * end *) diff --git a/src/stages/1-ast_imperative/misc.mli b/src/stages/1-ast_imperative/misc.mli deleted file mode 100644 index 0784d109c..000000000 --- a/src/stages/1-ast_imperative/misc.mli +++ /dev/null @@ -1,20 +0,0 @@ -open Trace -open Types - - -(* - -module Errors : sig - val different_literals_because_different_types : name -> literal -> literal -> unit -> error - - val different_literals : name -> literal -> literal -> unit -> error - - val error_uncomparable_literals : name -> literal -> literal -> unit -> error -end - -val assert_literal_eq : ( literal * literal ) -> unit result -*) - -val assert_value_eq : ( expression * expression ) -> unit result - -val is_value_eq : ( expression * expression ) -> bool diff --git a/src/stages/2-ast_sugar/ast_sugar.ml b/src/stages/2-ast_sugar/ast_sugar.ml index e9614490a..7fa34e677 100644 --- a/src/stages/2-ast_sugar/ast_sugar.ml +++ b/src/stages/2-ast_sugar/ast_sugar.ml @@ -3,6 +3,5 @@ include Types (* include Misc *) include Combinators module Types = Types -module Misc = Misc module PP=PP module Combinators = Combinators diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml deleted file mode 100644 index f65e95796..000000000 --- a/src/stages/2-ast_sugar/misc.ml +++ /dev/null @@ -1,350 +0,0 @@ -open Trace -open Types - -open Stage_common.Helpers -module Errors = struct - let different_literals_because_different_types name a b () = - let title () = "literals have different types: " ^ name in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let different_literals name a b () = - let title () = name ^ " are different" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () - - let error_uncomparable_literals name a b () = - let title () = name ^ " are not comparable" in - let message () = "" in - let data = [ - ("a" , fun () -> Format.asprintf "%a" PP.literal a) ; - ("b" , fun () -> Format.asprintf "%a" PP.literal b ) - ] in - error ~data title message () -end -open Errors - -let assert_literal_eq (a, b : literal * literal) : unit result = - match (a, b) with - | Literal_int a, Literal_int b when a = b -> ok () - | Literal_int _, Literal_int _ -> fail @@ different_literals "different ints" a b - | Literal_int _, _ -> fail @@ different_literals_because_different_types "int vs non-int" a b - | Literal_nat a, Literal_nat b when a = b -> ok () - | Literal_nat _, Literal_nat _ -> fail @@ different_literals "different nats" a b - | Literal_nat _, _ -> fail @@ different_literals_because_different_types "nat vs non-nat" a b - | Literal_timestamp a, Literal_timestamp b when a = b -> ok () - | Literal_timestamp _, Literal_timestamp _ -> fail @@ different_literals "different timestamps" a b - | Literal_timestamp _, _ -> fail @@ different_literals_because_different_types "timestamp vs non-timestamp" a b - | Literal_mutez a, Literal_mutez b when a = b -> ok () - | Literal_mutez _, Literal_mutez _ -> fail @@ different_literals "different tezs" a b - | Literal_mutez _, _ -> fail @@ different_literals_because_different_types "tez vs non-tez" a b - | Literal_string a, Literal_string b when a = b -> ok () - | Literal_string _, Literal_string _ -> fail @@ different_literals "different strings" a b - | Literal_string _, _ -> fail @@ different_literals_because_different_types "string vs non-string" a b - | Literal_bytes a, Literal_bytes b when a = b -> ok () - | Literal_bytes _, Literal_bytes _ -> fail @@ different_literals "different bytess" a b - | Literal_bytes _, _ -> fail @@ different_literals_because_different_types "bytes vs non-bytes" a b - | Literal_void, Literal_void -> ok () - | Literal_void, _ -> fail @@ different_literals_because_different_types "void vs non-void" a b - | Literal_unit, Literal_unit -> ok () - | Literal_unit, _ -> fail @@ different_literals_because_different_types "unit vs non-unit" a b - | Literal_address a, Literal_address b when a = b -> ok () - | Literal_address _, Literal_address _ -> fail @@ different_literals "different addresss" a b - | Literal_address _, _ -> fail @@ different_literals_because_different_types "address vs non-address" a b - | Literal_operation _, Literal_operation _ -> fail @@ error_uncomparable_literals "can't compare operations" a b - | Literal_operation _, _ -> fail @@ different_literals_because_different_types "operation vs non-operation" a b - | Literal_signature a, Literal_signature b when a = b -> ok () - | Literal_signature _, Literal_signature _ -> fail @@ different_literals "different signature" a b - | Literal_signature _, _ -> fail @@ different_literals_because_different_types "signature vs non-signature" a b - | Literal_key a, Literal_key b when a = b -> ok () - | Literal_key _, Literal_key _ -> fail @@ different_literals "different key" a b - | Literal_key _, _ -> fail @@ different_literals_because_different_types "key vs non-key" a b - | Literal_key_hash a, Literal_key_hash b when a = b -> ok () - | Literal_key_hash _, Literal_key_hash _ -> fail @@ different_literals "different key_hash" a b - | Literal_key_hash _, _ -> fail @@ different_literals_because_different_types "key_hash vs non-key_hash" a b - | Literal_chain_id a, Literal_chain_id b when a = b -> ok () - | Literal_chain_id _, Literal_chain_id _ -> fail @@ different_literals "different chain_id" a b - | Literal_chain_id _, _ -> fail @@ different_literals_because_different_types "chain_id vs non-chain_id" a b - -let rec assert_value_eq (a, b: (expression * expression )) : unit result = - Format.printf "in assert_value_eq %a %a\n%!" PP.expression a PP.expression b; - let error_content () = - Format.asprintf "\n@[- %a@;- %a]" PP.expression a PP.expression b - in - trace (fun () -> error (thunk "not equal") error_content ()) @@ - match (a.expression_content , b.expression_content) with - | E_literal a , E_literal b -> - assert_literal_eq (a, b) - | E_literal _ , _ -> - simple_fail "comparing a literal with not a literal" - | E_constant (ca) , E_constant (cb) when ca.cons_name = cb.cons_name -> ( - let%bind lst = - generic_try (simple_error "constants with different number of elements") - (fun () -> List.combine ca.arguments cb.arguments) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () - ) - | E_constant _ , E_constant _ -> - simple_fail "different constants" - | E_constant _ , _ -> - let error_content () = - Format.asprintf "%a vs %a" - PP.expression a - PP.expression b - in - fail @@ (fun () -> error (thunk "comparing constant with other expression") error_content ()) - - | E_constructor (ca), E_constructor (cb) when ca.constructor = cb.constructor -> ( - let%bind _eq = assert_value_eq (ca.element, cb.element) in - ok () - ) - | E_constructor _, E_constructor _ -> - simple_fail "different constructors" - | E_constructor _, _ -> - simple_fail "comparing constructor with other expression" - - - | E_record sma, E_record smb -> ( - let aux _ a b = - match a, b with - | Some a, Some b -> Some (assert_value_eq (a, b)) - | _ -> Some (simple_fail "different record keys") - in - let%bind _all = bind_lmap @@ LMap.merge aux sma smb in - ok () - ) - | E_record _, _ -> - simple_fail "comparing record with other expression" - - | E_record_update ura, E_record_update urb -> - let _ = - generic_try (simple_error "Updating different record") @@ - fun () -> assert_value_eq (ura.record, urb.record) in - let aux (Label a,Label b) = - assert (String.equal a b) - in - let () = aux (ura.path, urb.path) in - let%bind () = assert_value_eq (ura.update,urb.update) in - ok () - | E_record_update _, _ -> - simple_fail "comparing record update with other expression" - - | E_tuple lsta, E_tuple lstb -> ( - let%bind lst = - generic_try (simple_error "tuples with different number of elements") - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_list @@ List.map assert_value_eq lst in - ok () - ) - | E_tuple _, _ -> - simple_fail "comparing tuple with other expression" - - | E_tuple_update uta, E_tuple_update utb -> - let _ = - generic_try (simple_error "Updating different tuple") @@ - fun () -> assert_value_eq (uta.tuple, utb.tuple) in - let () = assert (uta.path == utb.path) in - let%bind () = assert_value_eq (uta.update,utb.update) in - ok () - | E_tuple_update _, _ -> - simple_fail "comparing tuple update with other expression" - - | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( - let%bind lst = generic_try (simple_error "maps of different lengths") - (fun () -> - let lsta' = List.sort compare lsta in - let lstb' = List.sort compare lstb in - List.combine lsta' lstb') in - let aux = fun ((ka, va), (kb, vb)) -> - let%bind _ = assert_value_eq (ka, kb) in - let%bind _ = assert_value_eq (va, vb) in - ok () in - let%bind _all = bind_map_list aux lst in - ok () - ) - | (E_map _ | E_big_map _), _ -> - simple_fail "comparing map with other expression" - - | E_list lsta, E_list lstb -> ( - let%bind lst = - generic_try (simple_error "list of different lengths") - (fun () -> List.combine lsta lstb) in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_list _, _ -> - simple_fail "comparing list with other expression" - - | E_set lsta, E_set lstb -> ( - let lsta' = List.sort (compare) lsta in - let lstb' = List.sort (compare) lstb in - let%bind lst = - generic_try (simple_error "set of different lengths") - (fun () -> List.combine lsta' lstb') in - let%bind _all = bind_map_list assert_value_eq lst in - ok () - ) - | E_set _, _ -> - simple_fail "comparing set with other expression" - - | (E_ascription a , _b') -> assert_value_eq (a.anno_expr , b) - | (_a' , E_ascription b) -> assert_value_eq (a , b.anno_expr) - | (E_variable _, _) | (E_lambda _, _) - | (E_application _, _) | (E_let_in _, _) - | (E_recursive _,_) - | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) - | (E_matching _, _) | (E_cond _, _) - | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" - -let is_value_eq (a , b) = to_bool @@ assert_value_eq (a , b) - -(* module Rename = struct - * open Trace - * - * module Type = struct - * (\* Type renaming, not needed. Yet. *\) - * end - * - * module Value = struct - * type renaming = string * (string * access_path) (\* src -> dst *\) - * type renamings = renaming list - * let filter (r:renamings) (s:string) : renamings = - * List.filter (fun (x, _) -> not (x = s)) r - * let filters (r:renamings) (ss:string list) : renamings = - * List.filter (fun (x, _) -> not (List.mem x ss)) r - * - * let rec rename_instruction (r:renamings) (i:instruction) : instruction result = - * match i with - * | I_assignment ({name;annotated_expression = e} as a) -> ( - * match List.assoc_opt name r with - * | None -> - * let%bind annotated_expression = rename_annotated_expression (filter r name) e in - * ok (I_assignment {a with annotated_expression}) - * | Some (name', lst) -> ( - * let%bind annotated_expression = rename_annotated_expression r e in - * match lst with - * | [] -> ok (I_assignment {name = name' ; annotated_expression}) - * | lst -> - * let (hds, tl) = - * let open List in - * let r = rev lst in - * rev @@ tl r, hd r - * in - * let%bind tl' = match tl with - * | Access_record n -> ok n - * | Access_tuple _ -> simple_fail "no support for renaming into tuples yet" in - * ok (I_record_patch (name', hds, [tl', annotated_expression])) - * ) - * ) - * | I_skip -> ok I_skip - * | I_fail e -> - * let%bind e' = rename_annotated_expression r e in - * ok (I_fail e') - * | I_loop (cond, body) -> - * let%bind cond' = rename_annotated_expression r cond in - * let%bind body' = rename_block r body in - * ok (I_loop (cond', body')) - * | I_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_block r m in - * ok (I_matching (ae', m')) - * | I_record_patch (v, path, lst) -> - * let aux (x, y) = - * let%bind y' = rename_annotated_expression (filter r v) y in - * ok (x, y') in - * let%bind lst' = bind_map_list aux lst in - * match List.assoc_opt v r with - * | None -> ( - * ok (I_record_patch (v, path, lst')) - * ) - * | Some (v', path') -> ( - * ok (I_record_patch (v', path' @ path, lst')) - * ) - * and rename_block (r:renamings) (bl:block) : block result = - * bind_map_list (rename_instruction r) bl - * - * and rename_matching : type a . (renamings -> a -> a result) -> renamings -> a matching -> a matching result = - * fun f r m -> - * match m with - * | Match_bool { match_true = mt ; match_false = mf } -> - * let%bind match_true = f r mt in - * let%bind match_false = f r mf in - * ok (Match_bool {match_true ; match_false}) - * | Match_option { match_none = mn ; match_some = (some, ms) } -> - * let%bind match_none = f r mn in - * let%bind ms' = f (filter r some) ms in - * ok (Match_option {match_none ; match_some = (some, ms')}) - * | Match_list { match_nil = mn ; match_cons = (hd, tl, mc) } -> - * let%bind match_nil = f r mn in - * let%bind mc' = f (filters r [hd;tl]) mc in - * ok (Match_list {match_nil ; match_cons = (hd, tl, mc')}) - * | Match_tuple (lst, body) -> - * let%bind body' = f (filters r lst) body in - * ok (Match_tuple (lst, body')) - * - * and rename_matching_instruction = fun x -> rename_matching rename_block x - * - * and rename_matching_expr = fun x -> rename_matching rename_expression x - * - * and rename_annotated_expression (r:renamings) (ae:annotated_expression) : annotated_expression result = - * let%bind expression = rename_expression r ae.expression in - * ok {ae with expression} - * - * and rename_expression : renamings -> expression -> expression result = fun r e -> - * match e with - * | E_literal _ as l -> ok l - * | E_constant (name, lst) -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_constant (name, lst')) - * | E_constructor (name, ae) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_constructor (name, ae')) - * | E_variable v -> ( - * match List.assoc_opt v r with - * | None -> ok (E_variable v) - * | Some (name, path) -> ok (E_accessor (ae (E_variable (name)), path)) - * ) - * | E_lambda ({binder;body;result} as l) -> - * let r' = filter r binder in - * let%bind body = rename_block r' body in - * let%bind result = rename_annotated_expression r' result in - * ok (E_lambda {l with body ; result}) - * | E_application (f, arg) -> - * let%bind f' = rename_annotated_expression r f in - * let%bind arg' = rename_annotated_expression r arg in - * ok (E_application (f', arg')) - * | E_tuple lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_tuple lst') - * | E_accessor (ae, p) -> - * let%bind ae' = rename_annotated_expression r ae in - * ok (E_accessor (ae', p)) - * | E_record sm -> - * let%bind sm' = bind_smap - * @@ SMap.map (rename_annotated_expression r) sm in - * ok (E_record sm') - * | E_map m -> - * let%bind m' = bind_map_list - * (fun (x, y) -> bind_map_pair (rename_annotated_expression r) (x, y)) m in - * ok (E_map m') - * | E_list lst -> - * let%bind lst' = bind_map_list (rename_annotated_expression r) lst in - * ok (E_list lst') - * | E_look_up m -> - * let%bind m' = bind_map_pair (rename_annotated_expression r) m in - * ok (E_look_up m') - * | E_matching (ae, m) -> - * let%bind ae' = rename_annotated_expression r ae in - * let%bind m' = rename_matching rename_annotated_expression r m in - * ok (E_matching (ae', m')) - * end - * end *) diff --git a/src/stages/2-ast_sugar/misc.mli b/src/stages/2-ast_sugar/misc.mli deleted file mode 100644 index 0784d109c..000000000 --- a/src/stages/2-ast_sugar/misc.mli +++ /dev/null @@ -1,20 +0,0 @@ -open Trace -open Types - - -(* - -module Errors : sig - val different_literals_because_different_types : name -> literal -> literal -> unit -> error - - val different_literals : name -> literal -> literal -> unit -> error - - val error_uncomparable_literals : name -> literal -> literal -> unit -> error -end - -val assert_literal_eq : ( literal * literal ) -> unit result -*) - -val assert_value_eq : ( expression * expression ) -> unit result - -val is_value_eq : ( expression * expression ) -> bool From 612f8aaf5ecd4760481d84b7b89f8cad215723c1 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 29 May 2020 16:06:44 +0200 Subject: [PATCH 08/32] vesion 1 --- src/passes/3-self_ast_imperative/helpers.ml | 15 +++++++++++++++ .../4-imperative_to_sugar/imperative_to_sugar.ml | 16 +++++++++++++--- src/passes/5-self_ast_sugar/helpers.ml | 15 +++++++++++++++ src/passes/6-sugar_to_core/sugar_to_core.ml | 9 +++++++++ src/stages/1-ast_imperative/PP.ml | 5 +++++ src/stages/1-ast_imperative/combinators.ml | 1 + src/stages/1-ast_imperative/combinators.mli | 1 + src/stages/1-ast_imperative/types.ml | 2 ++ src/stages/2-ast_sugar/PP.ml | 5 +++++ src/stages/2-ast_sugar/combinators.ml | 1 + src/stages/2-ast_sugar/combinators.mli | 1 + src/stages/2-ast_sugar/types.ml | 2 ++ 12 files changed, 70 insertions(+), 3 deletions(-) diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index e08e1ef53..66e0ef7d2 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -82,6 +82,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' tuple in ok res ) + | E_tuple_destruct {tuple; next} -> ( + let%bind res = self init' tuple in + let%bind res = self res next in + ok res + ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( let%bind res = self init' rhs in let%bind res = self res let_result in @@ -205,6 +210,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) + | E_tuple_destruct {tuple;fields;next} -> ( + let%bind tuple = self tuple in + let%bind next = self next in + return @@ E_tuple_destruct {tuple;fields;next} + ) | E_constructor c -> ( let%bind e' = self c.element in return @@ E_constructor {c with element = e'} @@ -384,6 +394,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) + | E_tuple_destruct {tuple;fields;next} -> ( + let%bind (res,tuple) = self init' tuple in + let%bind (res,next) = self res next in + ok (res, return @@ E_tuple_destruct {tuple;fields;next}) + ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 224c2de10..6ee20e2cd 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -57,9 +57,10 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam | E_constant _ | E_skip | E_literal _ | E_variable _ - | E_application _ | E_lambda _| E_recursive _ - | E_constructor _ | E_record _| E_record_accessor _|E_record_update _ - | E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ + | E_application _ | E_lambda _| E_recursive _ | E_constructor _ + | E_record _| E_record_accessor _|E_record_update _ | E_ascription _ + | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ + | E_tuple_destruct _ | E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ -> ok (true, (decl_var, free_var),ass_exp) ) @@ -104,6 +105,7 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : | E_application _ | E_lambda _| E_recursive _ | E_constructor _ | E_record _| E_record_accessor _|E_record_update _ | E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ + | E_tuple_destruct _ | E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ -> ok (true, (decl_var, free_var),ass_exp) ) @@ -335,6 +337,10 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind tuple = compile_expression tuple in let%bind update = compile_expression update in return @@ O.e_tuple_update ~loc tuple path update + | I.E_tuple_destruct {tuple; fields; next} -> + let%bind tuple = compile_expression tuple in + let%bind next = compile_expression next in + return @@ O.e_tuple_destruct ~loc tuple fields next | I.E_assign {variable; access_path; expression} -> let accessor ?loc s a = match a with @@ -724,6 +730,10 @@ let rec uncompile_expression' : O.expression -> I.expression result = let%bind tuple = uncompile_expression' tuple in let%bind update = uncompile_expression' update in return @@ I.E_tuple_update {tuple;path;update} + | O.E_tuple_destruct {tuple; fields; next} -> + let%bind tuple = uncompile_expression' tuple in + let%bind next = uncompile_expression' next in + return @@ I.E_tuple_destruct {tuple; fields; next} | O.E_map map -> let%bind map = bind_map_list ( bind_map_pair uncompile_expression' diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 953a8910f..2149ea9f8 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -99,6 +99,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' tuple in ok res ) + | E_tuple_destruct {tuple; next} -> ( + let%bind res = self init' tuple in + let%bind res = self res next in + ok res + ) and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> @@ -225,6 +230,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) + | E_tuple_destruct {tuple;fields;next} -> ( + let%bind tuple = self tuple in + let%bind next = self next in + return @@ E_tuple_destruct {tuple;fields;next} + ) | E_literal _ | E_variable _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> @@ -353,6 +363,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) + | E_tuple_destruct {tuple;fields;next} -> ( + let%bind (res,tuple) = self init' tuple in + let%bind (res,next) = self res next in + ok (res, return @@ E_tuple_destruct {tuple;fields;next}) + ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 165ff5577..22a89faa2 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -193,6 +193,15 @@ let rec compile_expression : I.expression -> O.expression result = let path = O.Label (string_of_int path) in let%bind update = compile_expression update in return @@ O.E_record_update {record;path;update} + | I.E_tuple_destruct {tuple; fields; next} -> + let%bind record = compile_expression tuple in + let%bind next = compile_expression next in + let aux ((index,e) : int * _ ) (field: I.expression_variable) = + let f = fun expr -> O.e_let_in (field, None) false (O.e_record_accessor record (string_of_int index)) expr in + (index+1, fun expr -> e (f expr)) + in + let (_,header) = List.fold_left aux (0, fun e -> e) fields in + ok @@ header next and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 6a2c835db..3147e4844 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -136,6 +136,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update + | E_tuple_destruct {tuple; fields; next} -> + fprintf ppf "{ let (%a) = %a in %a" + (list_sep_d expression_variable) fields + expression tuple + expression next | E_assign {variable; access_path; expression=e} -> fprintf ppf "%a%a := %a" expression_variable variable diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 4a4e88ed3..51a3330ae 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -140,6 +140,7 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update} +let e_tuple_destruct ?loc tuple fields next = make_e ?loc @@ E_tuple_destruct {tuple; fields; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 46e02fa9e..8c8047179 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -105,6 +105,7 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression +val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 4651c1f9f..1989c9e7f 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -77,6 +77,7 @@ and expression_content = | E_tuple of expression list | E_tuple_accessor of tuple_accessor | E_tuple_update of tuple_update + | E_tuple_destruct of tuple_destruct (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -144,6 +145,7 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} +and tuple_destruct = {tuple: expression; fields : expression_variable list; next : expression} and assign = { variable : expression_variable; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 3f348c52c..394115870 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -129,6 +129,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update + | E_tuple_destruct {tuple; fields; next} -> + fprintf ppf "{ let (%a) = %a in %a" + (list_sep_d expression_variable) fields + expression tuple + expression next and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 8c8890748..8d45a624d 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -129,6 +129,7 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update} +let e_tuple_destruct ?loc tuple fields next = make_e ?loc @@ E_tuple_destruct {tuple; fields; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index 3faebef21..bdf8b2b5e 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -85,6 +85,7 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression +val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 88df116fb..a24c4ebde 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -77,6 +77,7 @@ and expression_content = | E_tuple of expression list | E_tuple_accessor of tuple_accessor | E_tuple_update of tuple_update + | E_tuple_destruct of tuple_destruct (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -138,6 +139,7 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} +and tuple_destruct = {tuple: expression; fields : expression_variable list; next : expression} and environment_element_definition = | ED_binder From d6448727290fb0192fbef50a5bf99e4df59ad45c Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Fri, 29 May 2020 17:49:37 +0200 Subject: [PATCH 09/32] version 2 --- src/passes/3-self_ast_imperative/helpers.ml | 8 ++++---- .../4-imperative_to_sugar/imperative_to_sugar.ml | 10 ++++++---- src/passes/5-self_ast_sugar/helpers.ml | 8 ++++---- src/passes/6-sugar_to_core/sugar_to_core.ml | 16 ++++++++++++---- src/stages/1-ast_imperative/PP.ml | 2 +- src/stages/1-ast_imperative/combinators.ml | 2 +- src/stages/1-ast_imperative/combinators.mli | 2 +- src/stages/1-ast_imperative/types.ml | 2 +- src/stages/2-ast_sugar/PP.ml | 2 +- src/stages/2-ast_sugar/combinators.ml | 2 +- src/stages/2-ast_sugar/combinators.mli | 2 +- src/stages/2-ast_sugar/types.ml | 2 +- 12 files changed, 34 insertions(+), 24 deletions(-) diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index 66e0ef7d2..79e3b91c5 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -210,10 +210,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) - | E_tuple_destruct {tuple;fields;next} -> ( + | E_tuple_destruct {tuple;fields;field_types;next} -> ( let%bind tuple = self tuple in let%bind next = self next in - return @@ E_tuple_destruct {tuple;fields;next} + return @@ E_tuple_destruct {tuple;fields;field_types;next} ) | E_constructor c -> ( let%bind e' = self c.element in @@ -394,10 +394,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) - | E_tuple_destruct {tuple;fields;next} -> ( + | E_tuple_destruct {tuple;fields;field_types;next} -> ( let%bind (res,tuple) = self init' tuple in let%bind (res,next) = self res next in - ok (res, return @@ E_tuple_destruct {tuple;fields;next}) + ok (res, return @@ E_tuple_destruct {tuple;fields;field_types;next}) ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 6ee20e2cd..fda433669 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -337,10 +337,11 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind tuple = compile_expression tuple in let%bind update = compile_expression update in return @@ O.e_tuple_update ~loc tuple path update - | I.E_tuple_destruct {tuple; fields; next} -> + | I.E_tuple_destruct {tuple; fields; field_types; next} -> let%bind tuple = compile_expression tuple in let%bind next = compile_expression next in - return @@ O.e_tuple_destruct ~loc tuple fields next + let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in + return @@ O.e_tuple_destruct ~loc tuple fields field_types next | I.E_assign {variable; access_path; expression} -> let accessor ?loc s a = match a with @@ -730,10 +731,11 @@ let rec uncompile_expression' : O.expression -> I.expression result = let%bind tuple = uncompile_expression' tuple in let%bind update = uncompile_expression' update in return @@ I.E_tuple_update {tuple;path;update} - | O.E_tuple_destruct {tuple; fields; next} -> + | O.E_tuple_destruct {tuple; fields; field_types; next} -> let%bind tuple = uncompile_expression' tuple in let%bind next = uncompile_expression' next in - return @@ I.E_tuple_destruct {tuple; fields; next} + let%bind field_types = bind_map_option (bind_map_list uncompile_type_expression) field_types in + return @@ I.E_tuple_destruct {tuple; fields; field_types; next} | O.E_map map -> let%bind map = bind_map_list ( bind_map_pair uncompile_expression' diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 2149ea9f8..95d35d356 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -230,10 +230,10 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) - | E_tuple_destruct {tuple;fields;next} -> ( + | E_tuple_destruct {tuple;fields;field_types;next} -> ( let%bind tuple = self tuple in let%bind next = self next in - return @@ E_tuple_destruct {tuple;fields;next} + return @@ E_tuple_destruct {tuple;fields;field_types;next} ) | E_literal _ | E_variable _ | E_skip as e' -> return e' @@ -363,10 +363,10 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) - | E_tuple_destruct {tuple;fields;next} -> ( + | E_tuple_destruct {tuple;fields;field_types;next} -> ( let%bind (res,tuple) = self init' tuple in let%bind (res,next) = self res next in - ok (res, return @@ E_tuple_destruct {tuple;fields;next}) + ok (res, return @@ E_tuple_destruct {tuple;fields;field_types;next}) ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 22a89faa2..05d2600da 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -193,14 +193,22 @@ let rec compile_expression : I.expression -> O.expression result = let path = O.Label (string_of_int path) in let%bind update = compile_expression update in return @@ O.E_record_update {record;path;update} - | I.E_tuple_destruct {tuple; fields; next} -> + | I.E_tuple_destruct {tuple; fields; field_types; next} -> + let combine fields field_types = + match field_types with + Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft + | None -> List.map (fun x -> (x, None)) fields + in let%bind record = compile_expression tuple in let%bind next = compile_expression next in - let aux ((index,e) : int * _ ) (field: I.expression_variable) = - let f = fun expr -> O.e_let_in (field, None) false (O.e_record_accessor record (string_of_int index)) expr in + let%bind field_types = bind_map_option (bind_map_list idle_type_expression) field_types in + let aux ((index,e) : int * _ ) (field: O.expression_variable * O.type_expression option) = + let f = fun expr -> O.e_let_in field false (O.e_record_accessor record (string_of_int index)) expr in (index+1, fun expr -> e (f expr)) in - let (_,header) = List.fold_left aux (0, fun e -> e) fields in + let (_,header) = List.fold_left aux (0, fun e -> e) @@ + combine fields field_types + in ok @@ header next and compile_lambda : I.lambda -> O.lambda result = diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 3147e4844..081e5743a 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -136,7 +136,7 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update - | E_tuple_destruct {tuple; fields; next} -> + | E_tuple_destruct {tuple; fields; next; _} -> fprintf ppf "{ let (%a) = %a in %a" (list_sep_d expression_variable) fields expression tuple diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 51a3330ae..586c36c07 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -140,7 +140,7 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update} -let e_tuple_destruct ?loc tuple fields next = make_e ?loc @@ E_tuple_destruct {tuple; fields; next} +let e_tuple_destruct ?loc tuple fields field_types next = make_e ?loc @@ E_tuple_destruct {tuple; fields; field_types; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 8c8047179..68272942c 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -105,7 +105,7 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression -val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> expression -> expression +val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 1989c9e7f..19ab16d58 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -145,7 +145,7 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} -and tuple_destruct = {tuple: expression; fields : expression_variable list; next : expression} +and tuple_destruct = {tuple: expression; fields : expression_variable list; field_types : type_expression list option; next : expression} and assign = { variable : expression_variable; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 394115870..31b991f07 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -129,7 +129,7 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update - | E_tuple_destruct {tuple; fields; next} -> + | E_tuple_destruct {tuple; fields; next; _} -> fprintf ppf "{ let (%a) = %a in %a" (list_sep_d expression_variable) fields expression tuple diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 8d45a624d..dcf8ed421 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -129,7 +129,7 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update} -let e_tuple_destruct ?loc tuple fields next = make_e ?loc @@ E_tuple_destruct {tuple; fields; next} +let e_tuple_destruct ?loc tuple fields field_types next = make_e ?loc @@ E_tuple_destruct {tuple; fields; field_types; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index bdf8b2b5e..94529b898 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -85,7 +85,7 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression -val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> expression -> expression +val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index a24c4ebde..8c3422de6 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -139,7 +139,7 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} -and tuple_destruct = {tuple: expression; fields : expression_variable list; next : expression} +and tuple_destruct = {tuple: expression; fields : expression_variable list; field_types : type_expression list option; next : expression} and environment_element_definition = | ED_binder From 69a007cca9208fff305a27d6267c7dd85015684b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 26 May 2020 01:22:43 +0100 Subject: [PATCH 10/32] Describe the reason why a constraint or type was produced for more typer internals --- src/passes/8-typer-new/PP.ml | 6 +-- src/passes/8-typer-new/solver.ml | 73 ++++++++++++++++------------- src/passes/8-typer-new/wrap.ml | 71 ++++++++++++++-------------- src/passes/operators/operators.ml | 22 ++++----- src/stages/4-ast_typed/ast.ml | 16 ++++--- src/stages/4-ast_typed/misc.ml | 13 ++++- src/stages/4-ast_typed/misc.mli | 2 + src/stages/typesystem/misc.ml | 15 +++--- src/stages/typesystem/shorthands.ml | 17 ++++--- 9 files changed, 132 insertions(+), 103 deletions(-) diff --git a/src/passes/8-typer-new/PP.ml b/src/passes/8-typer-new/PP.ml index b76e55500..c5199f60d 100644 --- a/src/passes/8-typer-new/PP.ml +++ b/src/passes/8-typer-new/PP.ml @@ -2,7 +2,7 @@ open Ast_typed open Format module UF = UnionFind.Poly2 -let type_constraint_ : _ -> type_constraint_simpl_ -> unit = fun ppf -> +let type_constraint_ : _ -> type_constraint_simpl -> unit = fun ppf -> function |SC_Constructor { tv; c_tag; tv_list=_ } -> let ct = match c_tag with @@ -34,8 +34,8 @@ let type_constraint_ : _ -> type_constraint_simpl_ -> unit = fun ppf -> |SC_Poly _ -> fprintf ppf "Poly" |SC_Typeclass _ -> fprintf ppf "TC" -let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf { reason_simpl ; c_simpl } -> - fprintf ppf "%a (reason: %s)" type_constraint_ c_simpl reason_simpl +let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf c -> + fprintf ppf "%a (reason: %s)" type_constraint_ c (reason_simpl c) let all_constraints ppf ac = fprintf ppf "[%a]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";\n") type_constraint) ac diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 02ee01b7e..8bf2e30bf 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -159,7 +159,7 @@ let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_si UnionFindWrapper.add_constraints_related_to tvar constraints dbs in List.fold_left aux dbs tvars in - let dbs = match new_constraint.c_simpl with + let dbs = match new_constraint with SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []} | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]} | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []} @@ -173,7 +173,7 @@ let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_si TOOD: are we checking somewhere that 'b … = 'b2 … ? *) let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer = fun dbs new_constraint -> - match new_constraint.c_simpl with + match new_constraint with | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) -> let assignments = Map.update tv (function None -> Some c | e -> e) dbs.assignments in let dbs = {dbs with assignments} in @@ -191,7 +191,7 @@ let type_level_eval : type_value -> type_value * type_constraint list = failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *) + { tsrc = _ ; t = P_apply _ } -> failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *) | _ -> () in x @@ -210,16 +210,16 @@ let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer fun dbs new_constraint -> let insert_fresh a b = let fresh = Core.fresh_type_variable () in - let (dbs , cs1) = normalizer_simpl dbs (c_equation (P_variable fresh) a "normalizer: simpl") in - let (dbs , cs2) = normalizer_simpl dbs (c_equation (P_variable fresh) b "normalizer: simpl") in + let (dbs , cs1) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 1" ; t = P_variable fresh } a "normalizer: simpl 1") in + let (dbs , cs2) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 2" ; t = P_variable fresh } b "normalizer: simpl 2") in (dbs , cs1 @ cs2) in let split_constant a c_tag args = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> c_equation (P_variable v) t "normalizer: split_constant") (List.combine fresh_vars args) in + let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split_constant" ; t = P_variable v } t "normalizer: split_constant") (List.combine fresh_vars args) in let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs , [{c_simpl=SC_Constructor {tv=a;c_tag;tv_list=fresh_vars};reason_simpl="normalizer: split constant"}] @ List.flatten recur) in - let gather_forall a forall = (dbs , [{c_simpl=SC_Poly { tv=a; forall };reason_simpl="normalizer: gather_forall"}]) in - let gather_alias a b = (dbs , [{c_simpl=SC_Alias { a ; b };reason_simpl="normalizer: gather_alias"}]) in + (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars;reason_constr_simpl=Format.asprintf "normalizer: split constant %a = %a (%a)" Var.pp a Ast_typed.PP_generic.constant_tag c_tag (PP_helpers.list_sep Ast_typed.PP_generic.type_value (fun ppf () -> Format.fprintf ppf ", ")) args}] @ List.flatten recur) in + let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall ; reason_poly_simpl="normalizer: gather_forall"}]) in + let gather_alias a b = (dbs , [SC_Alias { a ; b ; reason_alias_simpl="normalizer: gather_alias"}]) in let reduce_type_app a b = let (reduced, new_constraints) = check_applied @@ type_level_eval b in let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in @@ -227,27 +227,27 @@ let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer (dbs , resimpl @ List.flatten recur) in let split_typeclass args tc = let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> c_equation (P_variable v) t "normalizer: split_typeclass") (List.combine fresh_vars args) in + let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split typeclass" ; t = P_variable v} t "normalizer: split_typeclass") (List.combine fresh_vars args) in let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs, [{c_simpl=SC_Typeclass { tc ; args = fresh_vars };reason_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in + (dbs, [SC_Typeclass { tc ; args = fresh_vars ; reason_typeclass_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in match new_constraint.c with (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) - | C_equation {aval=(P_forall _ as a); bval=(P_forall _ as b)} -> insert_fresh a b + | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) - | C_equation {aval=(P_forall _ as a); bval=(P_constant _ as b)} -> insert_fresh a b + | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) - | C_equation {aval=(P_constant _ as a); bval=(P_constant _ as b)} -> insert_fresh a b + | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) - | C_equation {aval=(P_constant _ as a); bval=(P_forall _ as b)} -> insert_fresh a b - | C_equation {aval=(P_forall forall); bval=(P_variable b)} -> gather_forall b forall - | C_equation {aval=P_variable a; bval=P_forall forall} -> gather_forall a forall - | C_equation {aval=P_variable a; bval=P_variable b} -> gather_alias a b - | C_equation {aval=P_variable a; bval=P_constant { p_ctor_tag; p_ctor_args }} -> split_constant a p_ctor_tag p_ctor_args - | C_equation {aval=P_constant {p_ctor_tag; p_ctor_args}; bval=P_variable b} -> split_constant b p_ctor_tag p_ctor_args + | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b + | C_equation {aval={ tsrc = _ ; t = P_forall forall }; bval={ tsrc = _ ; t = P_variable b }} -> gather_forall b forall + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_forall forall }} -> gather_forall a forall + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_variable b }} -> gather_alias a b + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_constant { p_ctor_tag; p_ctor_args } }} -> split_constant a p_ctor_tag p_ctor_args + | C_equation {aval={ tsrc = _ ; t = P_constant {p_ctor_tag; p_ctor_args} }; bval={ tsrc = _ ; t = P_variable b }} -> split_constant b p_ctor_tag p_ctor_args (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) - | C_equation {aval=(_ as a); bval=(P_apply _ as b)} -> reduce_type_app a b - | C_equation {aval=(P_apply _ as a); bval=(_ as b)} -> reduce_type_app b a + | C_equation {aval=(_ as a); bval=({ tsrc = _ ; t = P_apply _ } as b)} -> reduce_type_app a b + | C_equation {aval=({ tsrc = _ ; t = P_apply _ } as a); bval=(_ as b)} -> reduce_type_app b a (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *) @@ -325,7 +325,7 @@ type 'selector_output propagator = 'selector_output -> structured_dbs -> new_con let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = (* find two rules with the shape a = k(var …) and a = k'(var' …) *) fun type_constraint_simpl dbs -> - match type_constraint_simpl.c_simpl with + match type_constraint_simpl with SC_Constructor c -> (* finding other constraints related to the same type variable and with the same sort of constraint (constructor vs. constructor) @@ -473,7 +473,7 @@ let propagator_break_ctor : output_break_ctor propagator = (* produce constraints: *) (* a.tv = b.tv *) - let eq1 = c_equation (P_variable a.tv) (P_variable b.tv) "propagator: break_ctor" in + let eq1 = c_equation { tsrc = "solver: propagator: break_ctor a" ; t = P_variable a.tv} { tsrc = "solver: propagator: break_ctor b" ; t = P_variable b.tv} "propagator: break_ctor" in (* a.c_tag = b.c_tag *) if (compare_simple_c_constant a.c_tag b.c_tag) <> 0 then failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" debug_pp_c_constructor_simpl a debug_pp_c_constructor_simpl b (compare_simple_c_constant a.c_tag b.c_tag)) @@ -482,7 +482,7 @@ let propagator_break_ctor : output_break_ctor propagator = if List.length a.tv_list <> List.length b.tv_list then failwith "type error: incompatible types, not same length" else - let eqs3 = List.map2 (fun aa bb -> c_equation (P_variable aa) (P_variable bb) "propagator: break_ctor") a.tv_list b.tv_list in + let eqs3 = List.map2 (fun aa bb -> c_equation { tsrc = "solver: propagator: break_ctor aa" ; t = P_variable aa} { tsrc = "solver: propagator: break_ctor bb" ; t = P_variable bb} "propagator: break_ctor") a.tv_list b.tv_list in let eqs = eq1 :: eqs3 in (eqs , []) (* no new assignments *) @@ -507,7 +507,12 @@ let compare_label (a:label) (b:label) = let Label b = b in String.compare a b let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b -and compare_type_expression = function +and compare_type_expression { tsrc = _ ; t = ta } { tsrc = _ ; t = tb } = + (* Note: this comparison ignores the tsrc, the idea is that types + will often be compared to see if they are the same, regardless of + where the type comes from .*) + compare_type_expression_ ta tb +and compare_type_expression_ = function | P_forall { binder=a1; constraints=a2; body=a3 } -> (function | P_forall { binder=b1; constraints=b2; body=b3 } -> compare_type_variable a1 b1 @@ -559,7 +564,9 @@ let compare_p_forall let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = compare_type_variable a1 b1 compare_p_forall a2 b2 -let compare_c_constructor_simpl { tv=a1; c_tag=a2; tv_list=a3 } { tv=b1; c_tag=b2; tv_list=b3 } = +let compare_c_constructor_simpl { reason_constr_simpl = _ ; tv=a1; c_tag=a2; tv_list=a3 } { reason_constr_simpl = _ ; tv=b1; c_tag=b2; tv_list=b3 } = + (* We do not compare the reasons, as they are only for debugging and + not part of the type *) compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = @@ -574,7 +581,7 @@ let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) fun type_constraint_simpl dbs -> - match type_constraint_simpl.c_simpl with + match type_constraint_simpl with SC_Constructor c -> (* vice versa *) let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in @@ -594,17 +601,19 @@ let propagator_specialize1 : output_specialize1 propagator = let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) let a = selected.poly in let b = selected.a_k_var in - let () = if (a.tv <> b.tv) then failwith "internal error" else () in + + (* The selector is expected to provice two constraints with the shape (x = forall y, z) and x = k'(var' …) *) + assert (Var.equal (a : c_poly_simpl).tv (b : c_constructor_simpl).tv); (* produce constraints: *) - (* create a fresh existential variable to instantiate the polymorphic type b *) + (* create a fresh existential variable to instantiate the polymorphic type y *) let fresh_existential = Core.fresh_type_variable () in (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential]) The substitution is obtained by immediately applying the forall. *) - let apply = (P_apply {tf = (P_forall a.forall); targ = P_variable fresh_existential}) in + let apply = { tsrc = "solver: propagator: specialize1 apply" ; t = P_apply {tf = { tsrc = "solver: propagator: specialize1 tf" ; t = P_forall a.forall }; targ = { tsrc = "solver: propagator: specialize1 targ" ; t = P_variable fresh_existential }} } in let (reduced, new_constraints) = check_applied @@ type_level_eval apply in - let eq1 = c_equation (P_variable b.tv) reduced "propagator: specialize1" in + let eq1 = c_equation { tsrc = "solver: propagator: specialize1 eq1" ; t = P_variable b.tv } reduced "propagator: specialize1" in let eqs = eq1 :: new_constraints in (eqs, []) (* no new assignments *) diff --git a/src/passes/8-typer-new/wrap.ml b/src/passes/8-typer-new/wrap.ml index d14397b51..17d9c103d 100644 --- a/src/passes/8-typer-new/wrap.ml +++ b/src/passes/8-typer-new/wrap.ml @@ -44,7 +44,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun | T_arrow {type1;type2} -> p_constant C_arrow (List.map type_expression_to_type_value [ type1 ; type2 ]) - | T_variable (type_name) -> P_variable type_name + | T_variable (type_name) -> { tsrc = "wrap: from source code maybe?" ; t = P_variable type_name } | T_constant (type_name) -> let csttag = T.(match type_name with | TC_unit -> C_unit @@ -89,7 +89,7 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v p_constant C_record (List.map type_expression_to_type_value_copypasted tlist) | T_arrow {type1;type2} -> p_constant C_arrow (List.map type_expression_to_type_value_copypasted [ type1 ; type2 ]) - | T_variable type_name -> P_variable (type_name) (* eird stuff*) + | T_variable type_name -> { tsrc = "wrap: from source code maybe?" ; t = P_variable type_name } | T_constant (type_name) -> let csttag = T.(match type_name with | TC_unit -> C_unit @@ -121,12 +121,12 @@ let failwith_ : unit -> (constraints * O.type_variable) = fun () -> let variable : I.expression_variable -> T.type_expression -> (constraints * T.type_variable) = fun _name expr -> let pattern = type_expression_to_type_value expr in let type_name = Core.fresh_type_variable () in - [{ c = C_equation { aval = P_variable type_name ; bval = pattern } ; reason = "wrap: variable" }] , type_name + [{ c = C_equation { aval = { tsrc = "wrap: variable: whole" ; t = P_variable type_name } ; bval = pattern } ; reason = "wrap: variable" }] , type_name let literal : T.type_expression -> (constraints * T.type_variable) = fun t -> let pattern = type_expression_to_type_value t in let type_name = Core.fresh_type_variable () in - [{ c = C_equation { aval = P_variable type_name ; bval = pattern } ; reason = "wrap: literal" }] , type_name + [{ c = C_equation { aval = { tsrc = "wrap: literal: whole" ; t = P_variable type_name } ; bval = pattern } ; reason = "wrap: literal" }] , type_name (* let literal_bool : unit -> (constraints * O.type_variable) = fun () -> @@ -144,7 +144,7 @@ let tuple : T.type_expression list -> (constraints * T.type_variable) = fun tys let patterns = List.map type_expression_to_type_value tys in let pattern = p_constant C_record patterns in let type_name = Core.fresh_type_variable () in - [{ c = C_equation { aval = P_variable type_name ; bval = pattern} ; reason = "wrap: tuple" }] , type_name + [{ c = C_equation { aval = { tsrc = "wrap: tuple: whole" ; t = P_variable type_name } ; bval = pattern} ; reason = "wrap: tuple" }] , type_name (* let t_tuple = ('label:int, 'v) … -> record ('label : 'v) … *) (* let t_constructor = ('label:string, 'v) -> variant ('label : 'v) *) @@ -184,25 +184,25 @@ let constructor let sum = type_expression_to_type_value sum in let whole_expr = Core.fresh_type_variable () in [ - c_equation (P_variable whole_expr) sum "wrap: constructor: whole" ; + c_equation { tsrc = "wrap: constructor: whole" ; t = P_variable whole_expr } sum "wrap: constructor: whole" ; c_equation t_arg c_arg "wrap: construcotr: arg" ; ] , whole_expr let record : T.field_content T.label_map -> (constraints * T.type_variable) = fun fields -> let record_type = type_expression_to_type_value (T.t_record fields ()) in let whole_expr = Core.fresh_type_variable () in - [c_equation (P_variable whole_expr) record_type "wrap: record: whole"] , whole_expr + [c_equation { tsrc = "wrap: record: whole" ; t = P_variable whole_expr } record_type "wrap: record: whole"] , whole_expr let collection : O.constant_tag -> T.type_expression list -> (constraints * T.type_variable) = fun ctor element_tys -> - let elttype = T.P_variable (Core.fresh_type_variable ()) in + let elttype = T.{ tsrc = "wrap: collection: p_variable" ; t = P_variable (Core.fresh_type_variable ()) } in let aux elt = let elt' = type_expression_to_type_value elt in c_equation elttype elt' "wrap: collection: elt" in let equations = List.map aux element_tys in let whole_expr = Core.fresh_type_variable () in [ - c_equation (P_variable whole_expr) (p_constant ctor [elttype]) "wrap: collection: whole" ; + c_equation { tsrc = "wrap: collection: whole" ; t = P_variable whole_expr} (p_constant ctor [elttype]) "wrap: collection: whole" ; ] @ equations , whole_expr let list = collection T.C_list @@ -210,8 +210,8 @@ let set = collection T.C_set let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) = fun kv_tys -> - let k_type = T.P_variable (Core.fresh_type_variable ()) in - let v_type = T.P_variable (Core.fresh_type_variable ()) in + let k_type = T.{ tsrc = "wrap: map: k" ; t = P_variable (Core.fresh_type_variable ()) } in + let v_type = T.{ tsrc = "wrap: map: v" ; t = P_variable (Core.fresh_type_variable ()) } in let aux_k (k , _v) = let k' = type_expression_to_type_value k in c_equation k_type k' "wrap: map: key" in @@ -222,13 +222,13 @@ let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_ let equations_v = List.map aux_v kv_tys in let whole_expr = Core.fresh_type_variable () in [ - c_equation (P_variable whole_expr) (p_constant C_map [k_type ; v_type]) "wrap: map: whole" ; + c_equation ({ tsrc = "wrap: map: whole" ; t = P_variable whole_expr }) (p_constant C_map [k_type ; v_type]) "wrap: map: whole" ; ] @ equations_k @ equations_v , whole_expr let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) = fun kv_tys -> - let k_type = T.P_variable (Core.fresh_type_variable ()) in - let v_type = T.P_variable (Core.fresh_type_variable ()) in + let k_type = T.{ tsrc = "wrap: big_map: k" ; t = P_variable (Core.fresh_type_variable ()) } in + let v_type = T.{ tsrc = "wrap: big_map: v" ; t = P_variable (Core.fresh_type_variable ()) } in let aux_k (k , _v) = let k' = type_expression_to_type_value k in c_equation k_type k' "wrap: big_map: key" in @@ -241,7 +241,7 @@ let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.t [ (* TODO: this doesn't tag big_maps uniquely (i.e. if two big_map have the same type, they can be swapped. *) - c_equation (P_variable whole_expr) (p_constant C_big_map [k_type ; v_type]) "wrap: big_map: whole" ; + c_equation ({ tsrc = "wrap: big_map: whole" ; t = P_variable whole_expr}) (p_constant C_big_map [k_type ; v_type]) "wrap: big_map: whole" ; ] @ equations_k @ equations_v , whole_expr let application : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -250,7 +250,7 @@ let application : T.type_expression -> T.type_expression -> (constraints * T.typ let f' = type_expression_to_type_value f in let arg' = type_expression_to_type_value arg in [ - c_equation f' (p_constant C_arrow [arg' ; P_variable whole_expr]) "wrap: application: f" ; + c_equation f' (p_constant C_arrow [arg' ; { tsrc = "wrap: application: whole" ; t = P_variable whole_expr }]) "wrap: application: f" ; ] , whole_expr let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -258,10 +258,10 @@ let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_va let ds' = type_expression_to_type_value ds in let ind' = type_expression_to_type_value ind in let whole_expr = Core.fresh_type_variable () in - let v = Core.fresh_type_variable () in + let v = T.{ tsrc = "wrap: look_up: ds" ; t = P_variable (Core.fresh_type_variable ()) } in [ - c_equation ds' (p_constant C_map [ind' ; P_variable v]) "wrap: look_up: map" ; - c_equation (P_variable whole_expr) (p_constant C_option [P_variable v]) "wrap: look_up: whole" ; + c_equation ds' (p_constant C_map [ind' ; v]) "wrap: look_up: map" ; + c_equation ({ tsrc = "wrap: look_up: whole" ; t = P_variable whole_expr }) (p_constant C_option [v]) "wrap: look_up: whole" ; ] , whole_expr let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -271,7 +271,7 @@ let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_v let whole_expr = Core.fresh_type_variable () in [ c_equation a' (p_constant C_unit []) "wrap: sequence: first" ; - c_equation b' (P_variable whole_expr) "wrap: sequence: second (whole)" ; + c_equation b' ({ tsrc = "wrap: sequence: whole" ; t = P_variable whole_expr}) "wrap: sequence: second (whole)" ; ] , whole_expr let loop : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -280,9 +280,9 @@ let loop : T.type_expression -> T.type_expression -> (constraints * T.type_varia let body' = type_expression_to_type_value body in let whole_expr = Core.fresh_type_variable () in [ - c_equation expr' (P_variable Stage_common.Constant.t_bool) "wrap: loop: expr" ; + c_equation expr' ({ tsrc = "built-in type" ; t = P_variable Stage_common.Constant.t_bool }) "wrap: loop: expr" ; c_equation body' (p_constant C_unit []) "wrap: loop: body" ; - c_equation (P_variable whole_expr) (p_constant C_unit []) "wrap: loop: whole (unit)" ; + c_equation (p_constant C_unit []) ({ tsrc = "wrap: loop: whole" ; t = P_variable whole_expr}) "wrap: loop: whole (unit)" ; ] , whole_expr let let_in : T.type_expression -> T.type_expression option -> T.type_expression -> (constraints * T.type_variable) = @@ -294,7 +294,7 @@ let let_in : T.type_expression -> T.type_expression option -> T.type_expression | Some annot -> [c_equation rhs' (type_expression_to_type_value annot) "wrap: let_in: rhs"] in let whole_expr = Core.fresh_type_variable () in [ - c_equation result' (P_variable whole_expr) "wrap: let_in: result (whole)" ; + c_equation result' { tsrc = "wrap: let_in: whole" ; t = P_variable whole_expr } "wrap: let_in: result (whole)" ; ] @ rhs_tv_opt', whole_expr let recursive : T.type_expression -> (constraints * T.type_variable) = @@ -302,7 +302,7 @@ let recursive : T.type_expression -> (constraints * T.type_variable) = let fun_type = type_expression_to_type_value fun_type in let whole_expr = Core.fresh_type_variable () in [ - c_equation fun_type (P_variable whole_expr) "wrap: recursive: fun_type (whole)" ; + c_equation fun_type ({ tsrc = "wrap: recursive: whole" ; t = P_variable whole_expr }) "wrap: recursive: fun_type (whole)" ; ], whole_expr let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -312,7 +312,7 @@ let assign : T.type_expression -> T.type_expression -> (constraints * T.type_var let whole_expr = Core.fresh_type_variable () in [ c_equation v' e' "wrap: assign: var type must eq rhs type" ; - c_equation (P_variable whole_expr) (p_constant C_unit []) "wrap: assign: unit (whole)" ; + c_equation { tsrc = "wrap: assign: whole" ; t = P_variable whole_expr } (p_constant C_unit []) "wrap: assign: unit (whole)" ; ] , whole_expr let annotation : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = @@ -322,14 +322,14 @@ let annotation : T.type_expression -> T.type_expression -> (constraints * T.type let whole_expr = Core.fresh_type_variable () in [ c_equation e' annot' "wrap: annotation: expr type must eq annot" ; - c_equation e' (P_variable whole_expr) "wrap: annotation: whole" ; + c_equation e' { tsrc = "wrap: annotation: whole" ; t = P_variable whole_expr } "wrap: annotation: whole" ; ] , whole_expr let matching : T.type_expression list -> (constraints * T.type_variable) = fun es -> let whole_expr = Core.fresh_type_variable () in let type_expressions = (List.map type_expression_to_type_value es) in - let cs = List.map (fun e -> c_equation (P_variable whole_expr) e "wrap: matching: case (whole)") type_expressions + let cs = List.map (fun e -> c_equation { tsrc = "wrap: matching: case" ; t = P_variable whole_expr } e "wrap: matching: case (whole)") type_expressions in cs, whole_expr let fresh_binder () = @@ -342,19 +342,18 @@ let lambda (constraints * T.type_variable) = fun fresh arg body -> let whole_expr = Core.fresh_type_variable () in - let unification_arg = Core.fresh_type_variable () in - let unification_body = Core.fresh_type_variable () in + let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in + let unification_body = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in let arg' = match arg with None -> [] - | Some arg -> [c_equation (P_variable unification_arg) (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in + | Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in let body' = match body with None -> [] - | Some body -> [c_equation (P_variable unification_body) (type_expression_to_type_value body) "wrap: lambda: body annot"] + | Some body -> [c_equation unification_body (type_expression_to_type_value body) "wrap: lambda: body annot"] in [ - c_equation (type_expression_to_type_value fresh) (P_variable unification_arg) "wrap: lambda: arg" ; - c_equation (P_variable whole_expr) - (p_constant C_arrow ([P_variable unification_arg ; - P_variable unification_body])) + c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ; + c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr }) + (p_constant C_arrow ([unification_arg ; unification_body])) "wrap: lambda: arrow (whole)" ] @ arg' @ body' , whole_expr @@ -365,5 +364,5 @@ let constant : O.type_value -> T.type_expression list -> (constraints * T.type_v let args' = List.map type_expression_to_type_value args in let args_tuple = p_constant C_record args' in [ - c_equation f (p_constant C_arrow ([args_tuple ; P_variable whole_expr])) "wrap: constant: as declared for built-in" + c_equation f (p_constant C_arrow ([args_tuple ; { tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr }])) "wrap: constant: as declared for built-in" ] , whole_expr diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index ce870c27c..dc63d5573 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -434,17 +434,17 @@ module Typer = struct module Operators_types = struct open Typesystem.Shorthands - let tc_subarg a b c = tc [a;b;c] [ (*TODO…*) ] - let tc_sizearg a = tc [a] [ [int] ] - let tc_packable a = tc [a] [ [int] ; [string] ; [bool] (*TODO…*) ] - let tc_timargs a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] - let tc_edivargs a b c = tc [a;b;c] [ (*TODO…*) ] - let tc_divargs a b c = tc [a;b;c] [ (*TODO…*) ] - let tc_modargs a b c = tc [a;b;c] [ (*TODO…*) ] - let tc_addargs a b c = tc [a;b;c] [ (*TODO…*) ] - let tc_comparable a = tc [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ] - let tc_concatable a = tc [a] [ [string] ; [bytes] ] - let tc_storable a = tc [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ] + let tc_subarg a b c = tc "arguments for (-)" [a;b;c] [ (*TODO…*) ] + let tc_sizearg a = tc "arguments for size" [a] [ [int] ] + let tc_packable a = tc "packable" [a] [ [int] ; [string] ; [bool] (*TODO…*) ] + let tc_timargs a b c = tc "arguments for ( * )" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] + let tc_edivargs a b c = tc "arguments for ediv" [a;b;c] [ (*TODO…*) ] + let tc_divargs a b c = tc "arguments for div" [a;b;c] [ (*TODO…*) ] + let tc_modargs a b c = tc "arguments for mod" [a;b;c] [ (*TODO…*) ] + let tc_addargs a b c = tc "arguments for (+)" [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*TODO…*) ] + let tc_comparable a = tc "comparable" [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ] + let tc_concatable a = tc "concatenable" [a] [ [string] ; [bytes] ] + let tc_storable a = tc "storable" [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ] let t_none = forall "a" @@ fun a -> option a diff --git a/src/stages/4-ast_typed/ast.ml b/src/stages/4-ast_typed/ast.ml index 8a846aa61..99b532754 100644 --- a/src/stages/4-ast_typed/ast.ml +++ b/src/stages/4-ast_typed/ast.ml @@ -463,11 +463,15 @@ type constant_tag = | C_chain_id (* * *) (* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *) -type type_value = +type type_value_ = | P_forall of p_forall | P_variable of type_variable | P_constant of p_constant | P_apply of p_apply +and type_value = { + tsrc : string; + t : type_value_ ; +} and p_apply = { tf : type_value ; @@ -556,6 +560,7 @@ and constraints = { } and type_variable_list = type_variable list and c_constructor_simpl = { + reason_constr_simpl : string ; tv : type_variable; c_tag : constant_tag; tv_list : type_variable_list; @@ -569,24 +574,23 @@ and c_equation_e = { bex : type_expression ; } and c_typeclass_simpl = { + reason_typeclass_simpl : string ; tc : typeclass ; args : type_variable_list ; } and c_poly_simpl = { + reason_poly_simpl : string ; tv : type_variable ; forall : p_forall ; } -and type_constraint_simpl = { - reason_simpl : string ; - c_simpl : type_constraint_simpl_ ; - } -and type_constraint_simpl_ = +and type_constraint_simpl = | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) | SC_Alias of c_alias (* α = β *) | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *) | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) and c_alias = { + reason_alias_simpl : string ; a : type_variable ; b : type_variable ; } diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 7528dab2e..537a734f3 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -527,10 +527,19 @@ let equal_variables a b : bool = | E_variable a, E_variable b -> Var.equal a b | _, _ -> false -let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = - P_constant { +let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = { + tsrc = "misc.ml/p_constant" ; + t = P_constant { p_ctor_tag : constant_tag ; p_ctor_args : p_ctor_args ; } +} let c_equation aval bval reason = { c = C_equation { aval ; bval }; reason } + +let reason_simpl : type_constraint_simpl -> string = function + | SC_Constructor { reason_constr_simpl=reason; _ } + | SC_Alias { reason_alias_simpl=reason; _ } + | SC_Poly { reason_poly_simpl=reason; _ } + | SC_Typeclass { reason_typeclass_simpl=reason; _ } + -> reason diff --git a/src/stages/4-ast_typed/misc.mli b/src/stages/4-ast_typed/misc.mli index 561458303..71bb8a291 100644 --- a/src/stages/4-ast_typed/misc.mli +++ b/src/stages/4-ast_typed/misc.mli @@ -73,3 +73,5 @@ val get_entry : program -> string -> expression result val p_constant : constant_tag -> p_ctor_args -> type_value val c_equation : type_value -> type_value -> string -> type_constraint + +val reason_simpl : type_constraint_simpl -> string diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 336f8cdf2..bd693942c 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -223,24 +223,24 @@ module Substitution = struct and type_value ~tv ~substs = let self tv = type_value ~tv ~substs in let (v, expr) = substs in - match (tv : type_value) with + match (tv : type_value).t with | P_variable v' when Var.equal v' v -> expr | P_variable _ -> tv | P_constant {p_ctor_tag=x ; p_ctor_args=lst} -> ( let lst' = List.map self lst in - P_constant {p_ctor_tag=x ; p_ctor_args=lst'} + { tsrc = "?TODO1?" ; t = P_constant {p_ctor_tag=x ; p_ctor_args=lst'} } ) | P_apply { tf; targ } -> ( - P_apply { tf = self tf ; targ = self targ } + { tsrc = "?TODO2?" ; t = P_apply { tf = self tf ; targ = self targ } } ) | P_forall p -> ( let aux c = constraint_ ~c ~substs in let constraints = List.map aux p.constraints in if (p.binder = v) then ( - P_forall { p with constraints } + { tsrc = "?TODO3?" ; t = P_forall { p with constraints } } ) else ( let body = self p.body in - P_forall { p with constraints ; body } + { tsrc = "?TODO4?" ; t = P_forall { p with constraints ; body } } ) ) @@ -270,9 +270,10 @@ module Substitution = struct (* Performs beta-reduction at the root of the type *) let eval_beta_root ~(tv : type_value) = - match tv with - P_apply {tf = P_forall { binder; constraints; body }; targ} -> + match tv.t with + P_apply {tf = { tsrc = _ ; t = P_forall { binder; constraints; body } }; targ} -> let constraints = List.map (fun c -> constraint_ ~c ~substs:(mk_substs ~v:binder ~expr:targ)) constraints in + (* TODO: indicate in the result's tsrc that it was obtained via beta-reduction of the original type *) (type_value ~tv:body ~substs:(mk_substs ~v:binder ~expr:targ) , constraints) | _ -> (tv , []) end diff --git a/src/stages/typesystem/shorthands.ml b/src/stages/typesystem/shorthands.ml index 2e431b93c..dc82b2d09 100644 --- a/src/stages/typesystem/shorthands.ml +++ b/src/stages/typesystem/shorthands.ml @@ -2,19 +2,24 @@ open Ast_typed.Types open Core open Ast_typed.Misc -let tc type_vars allowed_list : type_constraint = - { c = C_typeclass {tc_args = type_vars ; typeclass = allowed_list} ; reason = "shorthands: typeclass" } +let tc description type_vars allowed_list : type_constraint = { + c = C_typeclass {tc_args = type_vars ;typeclass = allowed_list} ; + reason = "typeclass for operator: " ^ description + } let forall binder f = let () = ignore binder in let freshvar = fresh_type_variable () in - P_forall { binder = freshvar ; constraints = [] ; body = f (P_variable freshvar) } + let body = f { tsrc = "shorthands.ml/forall" ; t = P_variable freshvar } in + { tsrc = "shorthands.ml/forall" ; + t = P_forall { binder = freshvar ; constraints = [] ; body } } let forall_tc binder f = let () = ignore binder in let freshvar = fresh_type_variable () in - let (tc, ty) = f (P_variable freshvar) in - P_forall { binder = freshvar ; constraints = tc ; body = ty } + let (tc, ty) = f { tsrc = "shorthands.ml/forall_tc" ; t = P_variable freshvar } in + { tsrc = "shorthands.ml/forall_tc" ; + t = P_forall { binder = freshvar ; constraints = tc ; body = ty } } (* chained forall *) let forall2 a b f = @@ -55,7 +60,7 @@ let map k v = p_constant C_map [k; v] let unit = p_constant C_unit [] let list t = p_constant C_list [t] let set t = p_constant C_set [t] -let bool = P_variable Stage_common.Constant.t_bool +let bool = { tsrc = "built-in type" ; t = P_variable Stage_common.Constant.t_bool } let string = p_constant C_string [] let nat = p_constant C_nat [] let mutez = p_constant C_mutez [] From 36e4c426c99683d40106c81c54ea21de6531816c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 26 May 2020 01:26:11 +0100 Subject: [PATCH 11/32] assert that the selectors of rules elected constraints that match the propagator's expecations --- src/passes/8-typer-new/solver.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 8bf2e30bf..e9b59fe9e 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -323,7 +323,7 @@ type 'selector_output propagator = 'selector_output -> structured_dbs -> new_con * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = - (* find two rules with the shape a = k(var …) and a = k'(var' …) *) + (* find two rules with the shape x = k(var …) and x = k'(var' …) *) fun type_constraint_simpl dbs -> match type_constraint_simpl with SC_Constructor c -> @@ -470,6 +470,10 @@ let propagator_break_ctor : output_break_ctor propagator = let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) let a = selected.a_k_var in let b = selected.a_k'_var' in + + (* The selector is expected to provice two constraints with the shape x = k(var …) and x = k'(var' …) *) + assert (Var.equal (a : c_constructor_simpl).tv (b : c_constructor_simpl).tv); + (* produce constraints: *) (* a.tv = b.tv *) @@ -577,7 +581,7 @@ let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_va compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = - (* find two rules with the shape (a = forall b, d) and a = k'(var' …) or vice versa *) + (* find two rules with the shape (x = forall b, d) and x = k'(var' …) or vice versa *) (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) fun type_constraint_simpl dbs -> From 2633d732a3658cbdfe1828eecd27acbe627e3ef4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 26 May 2020 01:26:30 +0100 Subject: [PATCH 12/32] bugfix: Use Var.equal --- src/passes/8-typer-new/solver.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index e9b59fe9e..2ca9f1de2 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -589,13 +589,13 @@ let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector SC_Constructor c -> (* vice versa *) let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in - let other_cs = List.filter (fun (x : c_poly_simpl) -> c.tv = x.tv) other_cs in (* TODO: does equality work in OCaml? *) + let other_cs = List.filter (fun (x : c_poly_simpl) -> Var.equal c.tv x.tv) other_cs in let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in WasSelected cs_pairs | SC_Alias _ -> WasNotSelected (* TODO: ??? *) | SC_Poly p -> let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in - let other_cs = List.filter (fun (x : c_constructor_simpl) -> x.tv = p.tv) other_cs in (* TODO: does equality work in OCaml? *) + let other_cs = List.filter (fun (x : c_constructor_simpl) -> Var.equal x.tv p.tv) other_cs in let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in WasSelected cs_pairs | SC_Typeclass _ -> WasNotSelected From 4cb34a1d7e4ef3f0b2fbce7cbabf0292d72e3ef2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Tue, 26 May 2020 00:18:55 +0100 Subject: [PATCH 13/32] bugfix: new typer did not check a lambda's result' type against its annotation. --- src/passes/8-typer-new/typer.ml | 3 +-- src/passes/8-typer-new/wrap.ml | 15 +++++++++------ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 13a7def62..89f1183aa 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -420,8 +420,7 @@ and type_lambda e state { let e' = Environment.add_ez_binder (binder) fresh e in let%bind (result , state') = type_expression e' state result in - let () = Printf.printf "this does not make use of the typed body, this code sounds buggy." in - let wrapped = Solver.Wrap.lambda fresh input_type' output_type' in + let wrapped = Solver.Wrap.lambda fresh input_type' output_type' result.type_expression in ok (({binder;result}:O.lambda),state',wrapped) and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result = diff --git a/src/passes/8-typer-new/wrap.ml b/src/passes/8-typer-new/wrap.ml index 17d9c103d..5c0302887 100644 --- a/src/passes/8-typer-new/wrap.ml +++ b/src/passes/8-typer-new/wrap.ml @@ -339,23 +339,26 @@ let lambda : T.type_expression -> T.type_expression option -> T.type_expression option -> + T.type_expression -> (constraints * T.type_variable) = - fun fresh arg body -> + fun fresh arg output result -> let whole_expr = Core.fresh_type_variable () in let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in - let unification_body = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in + let unification_output = T.{ tsrc = "wrap: lambda: whole" ; t = P_variable (Core.fresh_type_variable ()) } in + let result' = type_expression_to_type_value result in let arg' = match arg with None -> [] | Some arg -> [c_equation unification_arg (type_expression_to_type_value arg) "wrap: lambda: arg annot"] in - let body' = match body with + let output' = match output with None -> [] - | Some body -> [c_equation unification_body (type_expression_to_type_value body) "wrap: lambda: body annot"] + | Some output -> [c_equation unification_output (type_expression_to_type_value output) "wrap: lambda: output annot"] in [ + c_equation unification_output result' "wrap: lambda: result" ; c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ; c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr }) - (p_constant C_arrow ([unification_arg ; unification_body])) + (p_constant C_arrow ([unification_arg ; unification_output])) "wrap: lambda: arrow (whole)" - ] @ arg' @ body' , whole_expr + ] @ arg' @ output' , whole_expr (* This is pretty much a wrapper for an n-ary function. *) let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) = From b2ee0035775d1d19bf3125c48488d98535ec358e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 29 May 2020 20:37:11 +0200 Subject: [PATCH 14/32] bugfix: new typer did not keep the state between the program and the test case's function call --- src/test/coase_tests.ml | 12 +++---- src/test/hash_lock_tests.ml | 28 ++++++++-------- src/test/id_tests.ml | 52 +++++++++++++++--------------- src/test/integration_tests.ml | 12 ++----- src/test/multisig_tests.ml | 28 ++++++++-------- src/test/multisig_v2_tests.ml | 40 +++++++++++------------ src/test/pledge_tests.ml | 12 +++---- src/test/replaceable_id_tests.ml | 16 ++++----- src/test/test_helpers.ml | 13 ++++---- src/test/time_lock_repeat_tests.ml | 8 ++--- src/test/time_lock_tests.ml | 8 ++--- src/test/tzip12_tests.ml | 32 +++++++++--------- src/test/vote_tests.ml | 7 ++-- 13 files changed, 130 insertions(+), 138 deletions(-) diff --git a/src/test/coase_tests.ml b/src/test/coase_tests.ml index f5d7819fd..c1cc1d680 100644 --- a/src/test/coase_tests.ml +++ b/src/test/coase_tests.ml @@ -13,15 +13,15 @@ let get_program = | Some s -> ok s | None -> ( let%bind (program , state) = type_file "./contracts/coase.ligo" in - let () = Typer.Solver.discard_state state in - s := Some program ; - ok program + s := Some (program , state) ; + ok (program , state) ) let compile_main () = - let%bind typed_prg = get_program () in - let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in - let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in + let%bind (typed_prg, state) = get_program () in + let () = Typer.Solver.discard_state state in + let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in + let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = (* fails if the given entry point is not a valid contract *) Ligo.Compile.Of_michelson.build_contract michelson_prg in diff --git a/src/test/hash_lock_tests.ml b/src/test/hash_lock_tests.ml index 3f9e79c79..b7bbe7bf1 100644 --- a/src/test/hash_lock_tests.ml +++ b/src/test/hash_lock_tests.ml @@ -50,7 +50,7 @@ let empty_message = e_lambda (Var.of_name "arguments") let commit () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in let%bind lock_time = mk_time "2000-01-02T00:10:11Z" in let test_hash_raw = sha_256_hash (Bytes.of_string "hello world") in @@ -79,12 +79,12 @@ let commit () = ~sender:first_contract () in - expect_eq ~options program "commit" + expect_eq ~options (program, state) "commit" (e_pair salted_hash init_storage) (e_pair empty_op_list post_storage) (* Test that the contract fails if we haven't committed before revealing the answer *) let reveal_no_commit () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); ("message", empty_message)] @@ -95,13 +95,13 @@ let reveal_no_commit () = ("salted_hash", (t_bytes ()))]) in let init_storage = storage test_hash true pre_commits in - expect_string_failwith program "reveal" + expect_string_failwith (program, state) "reveal" (e_pair reveal init_storage) "You have not made a commitment to hash against yet." (* Test that the contract fails if our commit isn't 24 hours old yet *) let reveal_young_commit () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); ("message", empty_message)] @@ -128,13 +128,13 @@ let reveal_young_commit () = ~sender:first_contract () in - expect_string_failwith ~options program "reveal" + expect_string_failwith ~options (program, state) "reveal" (e_pair reveal init_storage) "It has not been 24 hours since your commit yet." (* Test that the contract fails if our reveal doesn't meet our commitment *) let reveal_breaks_commit () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); ("message", empty_message)] @@ -160,13 +160,13 @@ let reveal_breaks_commit () = ~sender:first_contract () in - expect_string_failwith ~options program "reveal" + expect_string_failwith ~options (program, state) "reveal" (e_pair reveal init_storage) "This reveal does not match your commitment." (* Test that the contract fails if we reveal the wrong bytes for the stored hash *) let reveal_wrong_commit () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello"); ("message", empty_message)] @@ -192,13 +192,13 @@ let reveal_wrong_commit () = ~sender:first_contract () in - expect_string_failwith ~options program "reveal" + expect_string_failwith ~options (program, state) "reveal" (e_pair reveal init_storage) "Your commitment did not match the storage hash." (* Test that the contract fails if we try to reuse it after unused flag changed *) let reveal_no_reuse () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello"); ("message", empty_message)] @@ -224,13 +224,13 @@ let reveal_no_reuse () = ~sender:first_contract () in - expect_string_failwith ~options program "reveal" + expect_string_failwith ~options (program, state) "reveal" (e_pair reveal init_storage) "This contract has already been used." (* Test that the contract executes successfully with valid commit-reveal *) let reveal () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let empty_message = empty_message in let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); ("message", empty_message)] @@ -257,7 +257,7 @@ let reveal () = ~sender:first_contract () in - expect_eq ~options program "reveal" + expect_eq ~options (program, state) "reveal" (e_pair reveal init_storage) (e_pair empty_op_list post_storage) let main = test_suite "Hashlock" [ diff --git a/src/test/id_tests.ml b/src/test/id_tests.ml index f5839dd5b..a1fca2a62 100644 --- a/src/test/id_tests.ml +++ b/src/test/id_tests.ml @@ -33,7 +33,7 @@ let (first_owner , first_contract) = Protocol.Alpha_context.Contract.to_b58check kt , kt let buy_id () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -60,13 +60,13 @@ let buy_id () = e_int 2; e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in - let%bind () = expect_eq ~options program "buy" + let%bind () = expect_eq ~options (program, state) "buy" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () let buy_id_sender_addr () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -93,14 +93,14 @@ let buy_id_sender_addr () = e_int 2; e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in - let%bind () = expect_eq ~options program "buy" + let%bind () = expect_eq ~options (program, state) "buy" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () (* Test that contract fails if we attempt to buy an ID for the wrong amount *) let buy_id_wrong_amount () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -117,13 +117,13 @@ let buy_id_wrong_amount () = ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () in let param = e_pair owner_website (e_some (e_address new_addr)) in - let%bind () = expect_string_failwith ~options program "buy" + let%bind () = expect_string_failwith ~options (program, state) "buy" (e_pair param storage) "Incorrect amount paid." in ok () let update_details_owner () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -158,13 +158,13 @@ let update_details_owner () = let param = e_tuple [e_int 1 ; e_some details ; e_some (e_address new_addr)] in - let%bind () = expect_eq ~options program "update_details" + let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () let update_details_controller () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -199,14 +199,14 @@ let update_details_controller () = let param = e_tuple [e_int 1 ; e_some details ; e_some (e_address owner_addr)] in - let%bind () = expect_eq ~options program "update_details" + let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () (* Test that contract fails when we attempt to update details of nonexistent ID *) let update_details_nonexistent () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -233,14 +233,14 @@ let update_details_nonexistent () = let param = e_tuple [e_int 2 ; e_some details ; e_some (e_address owner_addr)] in - let%bind () = expect_string_failwith ~options program "update_details" + let%bind () = expect_string_failwith ~options (program, state) "update_details" (e_pair param storage) "This ID does not exist." in ok () (* Test that contract fails when we attempt to update details from wrong addr *) let update_details_wrong_addr () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -266,14 +266,14 @@ let update_details_wrong_addr () = let param = e_tuple [e_int 0 ; e_some details ; e_some (e_address owner_addr)] in - let%bind () = expect_string_failwith ~options program "update_details" + let%bind () = expect_string_failwith ~options (program, state) "update_details" (e_pair param storage) "You are not the owner or controller of this ID." in ok () (* Test that giving none on both profile and controller address is a no-op *) let update_details_unchanged () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -299,13 +299,13 @@ let update_details_unchanged () = let param = e_tuple [e_int 1 ; e_typed_none (t_bytes ()) ; e_typed_none (t_address ())] in - let%bind () = expect_eq ~options program "update_details" + let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) storage) in ok () let update_owner () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -337,14 +337,14 @@ let update_owner () = e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in let param = e_pair (e_int 1) (e_address owner_addr) in - let%bind () = expect_eq ~options program "update_owner" + let%bind () = expect_eq ~options (program, state) "update_owner" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () (* Test that contract fails when we attempt to update owner of nonexistent ID *) let update_owner_nonexistent () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -368,14 +368,14 @@ let update_owner_nonexistent () = e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in let param = e_pair (e_int 2) (e_address new_addr) in - let%bind () = expect_string_failwith ~options program "update_owner" + let%bind () = expect_string_failwith ~options (program, state) "update_owner" (e_pair param storage) "This ID does not exist." in ok () (* Test that contract fails when we attempt to update owner from non-owner addr *) let update_owner_wrong_addr () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -399,13 +399,13 @@ let update_owner_wrong_addr () = e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in let param = e_pair (e_int 0) (e_address new_addr) in - let%bind () = expect_string_failwith ~options program "update_owner" + let%bind () = expect_string_failwith ~options (program, state) "update_owner" (e_pair param storage) "You are not the owner of this ID." in ok () let skip () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -432,14 +432,14 @@ let skip () = e_int 3; e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in - let%bind () = expect_eq ~options program "skip" + let%bind () = expect_eq ~options (program, state) "skip" (e_pair (e_unit ()) storage) (e_pair (e_list []) new_storage) in ok () (* Test that contract fails if we try to skip without paying the right amount *) let skip_wrong_amount () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -461,7 +461,7 @@ let skip_wrong_amount () = e_int 2; e_tuple [e_mutez 1000000 ; e_mutez 1000000]] in - let%bind () = expect_string_failwith ~options program "skip" + let%bind () = expect_string_failwith ~options (program, state) "skip" (e_pair (e_unit ()) storage) "Incorrect amount paid." in ok () diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index bbe645b47..ab9242837 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -4,17 +4,11 @@ open Test_helpers open Ast_imperative.Combinators let retype_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" Env in - let () = Typer.Solver.discard_state state in - ok typed + Ligo.Compile.Utils.type_file f "reasonligo" Env let mtype_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" Env in - let () = Typer.Solver.discard_state state in - ok typed + Ligo.Compile.Utils.type_file f "cameligo" Env let type_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" Env in - let () = Typer.Solver.discard_state state in - ok typed + Ligo.Compile.Utils.type_file f "pascaligo" Env let type_alias () : unit result = let%bind program = type_file "./contracts/type-alias.ligo" in diff --git a/src/test/multisig_tests.ml b/src/test/multisig_tests.ml index b618dadd9..df3a42887 100644 --- a/src/test/multisig_tests.ml +++ b/src/test/multisig_tests.ml @@ -76,39 +76,39 @@ let params counter msg keys is_validl f s = (* Provide one valid signature when the threshold is two of two keys *) let not_enough_1_of_2 f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let exp_failwith = "Not enough signatures passed the check" in let keys = gen_keys () in let%bind test_params = params 0 empty_message [keys] [true] f s in let%bind () = expect_string_failwith - program "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in + (program, state) "main" (e_pair test_params (init_storage 2 0 [keys;gen_keys()])) exp_failwith in ok () let unmatching_counter f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let exp_failwith = "Counters does not match" in let keys = gen_keys () in let%bind test_params = params 1 empty_message [keys] [true] f s in let%bind () = expect_string_failwith - program "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in + (program, state) "main" (e_pair test_params (init_storage 1 0 [keys])) exp_failwith in ok () (* Provide one invalid signature (correct key but incorrect signature) when the threshold is one of one key *) let invalid_1_of_1 f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let exp_failwith = "Invalid signature" in let keys = [gen_keys ()] in let%bind test_params = params 0 empty_message keys [false] f s in let%bind () = expect_string_failwith - program "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in + (program, state) "main" (e_pair test_params (init_storage 1 0 keys)) exp_failwith in ok () (* Provide one valid signature when the threshold is one of one key *) let valid_1_of_1 f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let keys = gen_keys () in - let%bind () = expect_eq_n_trace_aux [0;1;2] program "main" + let%bind () = expect_eq_n_trace_aux [0;1;2] (program, state) "main" (fun n -> let%bind params = params n empty_message [keys] [true] f s in ok @@ e_pair params (init_storage 1 n [keys]) @@ -120,10 +120,10 @@ let valid_1_of_1 f s () = (* Provive two valid signatures when the threshold is two of three keys *) let valid_2_of_3 f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let param_keys = [gen_keys (); gen_keys ()] in let st_keys = param_keys @ [gen_keys ()] in - let%bind () = expect_eq_n_trace_aux [0;1;2] program "main" + let%bind () = expect_eq_n_trace_aux [0;1;2] (program, state) "main" (fun n -> let%bind params = params n empty_message param_keys [true;true] f s in ok @@ e_pair params (init_storage 2 n st_keys) @@ -135,7 +135,7 @@ let valid_2_of_3 f s () = (* Provide one invalid signature and two valid signatures when the threshold is two of three keys *) let invalid_3_of_3 f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let valid_keys = [gen_keys() ; gen_keys()] in let invalid_key = gen_keys () in let param_keys = valid_keys @ [invalid_key] in @@ -143,18 +143,18 @@ let invalid_3_of_3 f s () = let%bind test_params = params 0 empty_message param_keys [false;true;true] f s in let exp_failwith = "Invalid signature" in let%bind () = expect_string_failwith - program "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in + (program, state) "main" (e_pair test_params (init_storage 2 0 st_keys)) exp_failwith in ok () (* Provide two valid signatures when the threshold is three of three keys *) let not_enough_2_of_3 f s () = - let%bind program,_ = get_program f s() in + let%bind (program , state) = get_program f s() in let valid_keys = [gen_keys() ; gen_keys()] in let st_keys = gen_keys () :: valid_keys in let%bind test_params = params 0 empty_message (valid_keys) [true;true] f s in let exp_failwith = "Not enough signatures passed the check" in let%bind () = expect_string_failwith - program "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in + (program, state) "main" (e_pair test_params (init_storage 3 0 st_keys)) exp_failwith in ok () let main = test_suite "Multisig" [ diff --git a/src/test/multisig_v2_tests.ml b/src/test/multisig_v2_tests.ml index bf163195c..6c230881e 100644 --- a/src/test/multisig_v2_tests.ml +++ b/src/test/multisig_v2_tests.ml @@ -65,7 +65,7 @@ let storage {state_hash ; threshold ; max_proposal ; max_msg_size ; id_counter_l (* sender not stored in the authorized set *) let wrong_addr () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage { threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; id_counter_list = [1,0 ; 2,0] ; @@ -75,13 +75,13 @@ let wrong_addr () = let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in let%bind () = let exp_failwith = "Unauthorized address" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair (send_param empty_message) init_storage) exp_failwith in ok () (* send a message which exceed the size limit *) let message_size_exceeded () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage { threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; id_counter_list = [1,0] ; @@ -91,13 +91,13 @@ let message_size_exceeded () = let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in let%bind () = let exp_failwith = "Message size exceed maximum limit" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair (send_param empty_message) init_storage) exp_failwith in ok () (* sender has already has reached maximum number of proposal *) let maximum_number_of_proposal () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload1 = pack_payload program (send_param empty_message) in let bytes1 = e_bytes_raw packed_payload1 in let init_storage = storage { @@ -109,13 +109,13 @@ let maximum_number_of_proposal () = let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in let%bind () = let exp_failwith = "Maximum number of proposal reached" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair (send_param empty_message2) init_storage) exp_failwith in ok () (* sender message is already stored in the message store *) let send_already_accounted () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let init_storage = storage { @@ -126,12 +126,12 @@ let send_already_accounted () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair (send_param empty_message) init_storage) (e_pair empty_op_list init_storage) (* sender message isn't stored in the message store *) let send_never_accounted () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let init_storage' = { @@ -147,12 +147,12 @@ let send_never_accounted () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair (send_param empty_message) init_storage) (e_pair empty_op_list final_storage) (* sender withdraw message is already binded to one address in the message store *) let withdraw_already_accounted_one () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let param = withdraw_param in @@ -168,12 +168,12 @@ let withdraw_already_accounted_one () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list final_storage) (* sender withdraw message is already binded to two addresses in the message store *) let withdraw_already_accounted_two () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let param = withdraw_param in @@ -189,12 +189,12 @@ let withdraw_already_accounted_two () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list final_storage) (* triggers the threshold and check that all the participants get their counters decremented *) let counters_reset () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let param = send_param empty_message in @@ -212,12 +212,12 @@ let counters_reset () = let options = let sender = contract 3 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list final_storage) (* sender withdraw message was never accounted *) let withdraw_never_accounted () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let param = withdraw_param in let init_storage = storage { threshold = 2 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; @@ -227,12 +227,12 @@ let withdraw_never_accounted () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list init_storage) (* successful storing in the message store *) let succeeded_storing () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind packed_payload = pack_payload program empty_message in let bytes = e_bytes_raw packed_payload in let init_storage th = { @@ -243,7 +243,7 @@ let succeeded_storing () = let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - let%bind () = expect_eq_n_trace_aux ~options [1;2] program "main" + let%bind () = expect_eq_n_trace_aux ~options [1;2] (program, state) "main" (fun th -> let init_storage = storage (init_storage th) in ok @@ e_pair (send_param empty_message) init_storage diff --git a/src/test/pledge_tests.ml b/src/test/pledge_tests.ml index a10b17295..6f6b371ea 100644 --- a/src/test/pledge_tests.ml +++ b/src/test/pledge_tests.ml @@ -45,36 +45,36 @@ let empty_message = e_lambda (Var.of_name "arguments") let pledge () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let storage = e_address oracle_addr in let parameter = e_unit () in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:oracle_contract ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () in - expect_eq ~options program "donate" + expect_eq ~options (program, state) "donate" (e_pair parameter storage) (e_pair (e_list []) storage) let distribute () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let storage = e_address oracle_addr in let parameter = empty_message in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:oracle_contract () in - expect_eq ~options program "distribute" + expect_eq ~options (program, state) "distribute" (e_pair parameter storage) (e_pair (e_list []) storage) let distribute_unauthorized () = - let%bind program, _ = get_program () in + let%bind (program , state) = get_program () in let storage = e_address oracle_addr in let parameter = empty_message in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:stranger_contract () in - expect_string_failwith ~options program "distribute" + expect_string_failwith ~options (program, state) "distribute" (e_pair parameter storage) "You're not the oracle for this distribution." diff --git a/src/test/replaceable_id_tests.ml b/src/test/replaceable_id_tests.ml index 6de612bab..771b439a7 100644 --- a/src/test/replaceable_id_tests.ml +++ b/src/test/replaceable_id_tests.ml @@ -39,45 +39,45 @@ let entry_pass_message = e_constructor "Pass_message" @@ empty_message let change_addr_success () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage 1 in let param = entry_change_addr 2 in let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list (storage 2)) let change_addr_fail () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage 1 in let param = entry_change_addr 2 in let options = let sender = contract 3 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in let exp_failwith = "Unauthorized sender" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair param init_storage) exp_failwith let pass_message_success () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage 1 in let param = entry_pass_message in let options = let sender = contract 1 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair param init_storage) (e_pair empty_op_list init_storage) let pass_message_fail () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let init_storage = storage 1 in let param = entry_pass_message in let options = let sender = contract 2 in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in let exp_failwith = "Unauthorized sender" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair param init_storage) exp_failwith let main = test_suite "Replaceable ID" [ diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index adeb5649a..cc1e25afb 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -86,11 +86,10 @@ let sha_256_hash pl = open Ast_imperative.Combinators let typed_program_with_imperative_input_to_michelson - (program: Ast_typed.program) (entry_point: string) + ((program , state): Ast_typed.program * Ast_typed.typer_state) (entry_point: string) (input: Ast_imperative.expression) : Compiler.compiled_expression result = Printexc.record_backtrace true; let env = Ast_typed.program_environment Environment.default program in - let state = Typer.Solver.initial_state in let%bind sugar = Compile.Of_imperative.compile_expression input in let%bind core = Compile.Of_sugar.compile_expression sugar in let%bind app = Compile.Of_core.apply entry_point core in @@ -100,9 +99,9 @@ let typed_program_with_imperative_input_to_michelson Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied let run_typed_program_with_imperative_input ?options - (program: Ast_typed.program) (entry_point: string) + ((program , state): Ast_typed.program * Ast_typed.typer_state) (entry_point: string) (input: Ast_imperative.expression) : Ast_core.expression result = - let%bind michelson_program = typed_program_with_imperative_input_to_michelson program entry_point input in + let%bind michelson_program = typed_program_with_imperative_input_to_michelson (program , state) entry_point input in let%bind michelson_output = Ligo.Run.Of_michelson.run_no_failwith ?options michelson_program.expr michelson_program.expr_ty in Uncompile.uncompile_typed_program_entry_function_result program entry_point michelson_output @@ -160,7 +159,7 @@ let expect_eq_core ?options program entry_point input expected = Ast_core.Misc.assert_value_eq (expected,result) in expect ?options program entry_point input expecter -let expect_evaluate program entry_point expecter = +let expect_evaluate (program, _state) entry_point expecter = let error = let title () = "expect evaluate" in let content () = Format.asprintf "Entry_point: %s" entry_point in @@ -173,11 +172,11 @@ let expect_evaluate program entry_point expecter = let%bind res_simpl = Uncompile.uncompile_typed_program_entry_expression_result program entry_point res_michelson in expecter res_simpl -let expect_eq_evaluate program entry_point expected = +let expect_eq_evaluate ((program , state) : Ast_typed.program * Ast_typed.typer_state) entry_point expected = let%bind expected = expression_to_core expected in let expecter = fun result -> Ast_core.Misc.assert_value_eq (expected , result) in - expect_evaluate program entry_point expecter + expect_evaluate (program, state) entry_point expecter let expect_n_aux ?options lst program entry_point make_input make_expecter = let aux n = diff --git a/src/test/time_lock_repeat_tests.ml b/src/test/time_lock_repeat_tests.ml index adfe66169..efadf31a2 100644 --- a/src/test/time_lock_repeat_tests.ml +++ b/src/test/time_lock_repeat_tests.ml @@ -43,21 +43,21 @@ let storage st interval execute = ("execute", execute)] let early_call () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in let init_storage = storage lock_time 86400 empty_message in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in let exp_failwith = "You have to wait before you can execute this contract again." in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair (e_unit ()) init_storage) exp_failwith let fake_uncompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]" (* Test that when we use the contract the next use time advances by correct interval *) let interval_advance () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in let init_storage = storage lock_time 86400 empty_message in @@ -66,7 +66,7 @@ let interval_advance () = let new_storage_fake = storage new_timestamp 86400 fake_uncompiled_empty_message in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair (e_unit ()) init_storage) (e_pair empty_op_list new_storage_fake) let main = test_suite "Time Lock Repeating" [ diff --git a/src/test/time_lock_tests.ml b/src/test/time_lock_tests.ml index f345401c9..ee99d1542 100644 --- a/src/test/time_lock_tests.ml +++ b/src/test/time_lock_tests.ml @@ -41,24 +41,24 @@ let to_sec t = Tezos_utils.Time.Protocol.to_seconds t let storage st = e_timestamp (Int64.to_int @@ to_sec st) let early_call () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in let init_storage = storage lock_time in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in let exp_failwith = "Contract is still time locked" in - expect_string_failwith ~options program "main" + expect_string_failwith ~options (program, state) "main" (e_pair (call empty_message) init_storage) exp_failwith let call_on_time () = - let%bind program,_ = get_program () in + let%bind (program , state) = get_program () in let%bind predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in let init_storage = storage lock_time in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in - expect_eq ~options program "main" + expect_eq ~options (program, state) "main" (e_pair (call empty_message) init_storage) (e_pair empty_op_list init_storage) let main = test_suite "Time lock" [ diff --git a/src/test/tzip12_tests.ml b/src/test/tzip12_tests.ml index db5996c9e..af81b9672 100644 --- a/src/test/tzip12_tests.ml +++ b/src/test/tzip12_tests.ml @@ -49,7 +49,7 @@ let sender = e_address @@ sender let external_contract = e_annotation (e_constant C_IMPLICIT_ACCOUNT [e_key_hash external_contract]) (t_contract (t_nat ())) let transfer f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair sender from_, e_nat 100)]); @@ -64,10 +64,10 @@ let transfer f s () = let input = e_pair parameter storage in let expected = e_pair (e_typed_list [] (t_operation ())) new_storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_eq program ~options "transfer" input expected + expect_eq (program, state) ~options "transfer" input expected let transfer_not_e_allowance f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair sender from_, e_nat 0)]); @@ -76,11 +76,11 @@ let transfer_not_e_allowance f s () = let parameter = e_record_ez [("address_from", from_);("address_to",to_); ("value",e_nat 10)] in let input = e_pair parameter storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_string_failwith ~options program "transfer" input + expect_string_failwith ~options (program, state) "transfer" input "Not Enough Allowance" let transfer_not_e_balance f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 0); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair sender from_, e_nat 100)]); @@ -89,11 +89,11 @@ let transfer_not_e_balance f s () = let parameter = e_record_ez [("address_from", from_);("address_to",to_); ("value",e_nat 10)] in let input = e_pair parameter storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_string_failwith ~options program "transfer" input + expect_string_failwith ~options (program, state) "transfer" input "Not Enough Balance" let approve f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair from_ sender, e_nat 0)]); @@ -108,10 +108,10 @@ let approve f s () = let input = e_pair parameter storage in let expected = e_pair (e_typed_list [] (t_operation ())) new_storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_eq program ~options "approve" input expected + expect_eq (program, state) ~options "approve" input expected let approve_unsafe f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair from_ sender, e_nat 100)]); @@ -120,11 +120,11 @@ let approve_unsafe f s () = let parameter = e_record_ez [("spender", from_);("value",e_nat 100)] in let input = e_pair parameter storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_string_failwith ~options program "approve" input + expect_string_failwith ~options (program, state) "approve" input "Unsafe Allowance Change" let get_allowance f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair from_ sender, e_nat 100)]); @@ -134,10 +134,10 @@ let get_allowance f s () = let input = e_pair parameter storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_eq program ~options "getAllowance" input expected + expect_eq (program, state) ~options "getAllowance" input expected let get_balance f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair from_ sender, e_nat 100)]); @@ -147,10 +147,10 @@ let get_balance f s () = let input = e_pair parameter storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_eq program ~options "getBalance" input expected + expect_eq (program, state) ~options "getBalance" input expected let get_total_supply f s () = - let%bind program,_ = get_program f s () in + let%bind (program , state) = get_program f s () in let storage = e_record_ez [ ("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("allowances", e_big_map [(e_pair from_ sender, e_nat 100)]); @@ -160,7 +160,7 @@ let get_total_supply f s () = let input = e_pair parameter storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in let options = Proto_alpha_utils.Memory_proto_alpha.make_options () in - expect_eq program ~options "getTotalSupply" input expected + expect_eq (program, state) ~options "getTotalSupply" input expected let main = test_suite "tzip-12" [ test "transfer" (transfer file_FA12 "pascaligo"); diff --git a/src/test/vote_tests.ml b/src/test/vote_tests.ml index 24cce7663..89f829a86 100644 --- a/src/test/vote_tests.ml +++ b/src/test/vote_tests.ml @@ -2,8 +2,7 @@ open Trace open Test_helpers let type_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") in - ok @@ (typed,state) + Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") let get_program = let s = ref None in @@ -36,10 +35,10 @@ let reset title start_time finish_time = let yea = e_constructor "Vote" (e_constructor "Yea" (e_unit ())) let init_vote () = - let%bind (program , _) = get_program () in + let%bind (program , state) = get_program () in let%bind result = Test_helpers.run_typed_program_with_imperative_input - program "main" (e_pair yea (init_storage "basic")) in + (program, state) "main" (e_pair yea (init_storage "basic")) in let%bind (_, storage) = Ast_core.extract_pair result in let%bind storage' = Ast_core.extract_record storage in (* let votes = List.assoc (Label "voters") storage' in From d5a6f464522c3a8f3f4b6ff8acb048c9fa1c4618 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 7 May 2020 23:01:50 +0100 Subject: [PATCH 15/32] Fix indentation of one function (only whitespace change) --- src/passes/8-typer-new/solver.ml | 37 +++++++++++++++++--------------- 1 file changed, 20 insertions(+), 17 deletions(-) diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 2ca9f1de2..04ebf8236 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -621,23 +621,26 @@ let propagator_specialize1 : output_specialize1 propagator = let eqs = eq1 :: new_constraints in (eqs, []) (* no new assignments *) - let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments = - let mem elt set = match RedBlackTrees.PolySet.find_opt elt set with None -> false | Some _ -> true in - fun selector propagator -> - fun already_selected old_type_constraint dbs -> - (* TODO: thread some state to know which selector outputs were already seen *) - match selector old_type_constraint dbs with - WasSelected selected_outputs -> - (* TODO: fold instead. *) - let (already_selected , selected_outputs) = List.fold_left (fun (already_selected, selected_outputs) elt -> if mem elt already_selected then (RedBlackTrees.PolySet.add elt already_selected , elt :: selected_outputs) - else (already_selected , selected_outputs)) (already_selected , selected_outputs) selected_outputs in - (* Call the propagation rule *) - let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in - let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in - (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) - (already_selected , List.flatten new_constraints , List.flatten new_assignments) - | WasNotSelected -> - (already_selected, [] , []) +let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments = + let mem elt set = match RedBlackTrees.PolySet.find_opt elt set with None -> false | Some _ -> true in + fun selector propagator -> + fun already_selected old_type_constraint dbs -> + (* TODO: thread some state to know which selector outputs were already seen *) + match selector old_type_constraint dbs with + WasSelected selected_outputs -> + (* TODO: fold instead. *) + let (already_selected , selected_outputs) = + List.fold_left (fun (already_selected, selected_outputs) elt -> + if mem elt already_selected + then (RedBlackTrees.PolySet.add elt already_selected , elt :: selected_outputs) + else (already_selected , selected_outputs)) (already_selected , selected_outputs) selected_outputs in + (* Call the propagation rule *) + let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in + let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in + (* return so that the new constraints are pushed to some kind of work queue and the new assignments stored *) + (already_selected , List.flatten new_constraints , List.flatten new_assignments) + | WasNotSelected -> + (already_selected, [] , []) let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 From 4a860830b9d6b04e9e09c7370b569cf82eda559a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Fri, 8 May 2020 15:24:42 +0100 Subject: [PATCH 16/32] bugfix: replace very bogus implementation of add_list with a clean one --- src/passes/8-typer-new/solver.ml | 9 ++------- src/stages/typesystem/misc.ml | 16 ++++++---------- vendors/Red-Black_Trees/PolySet.ml | 11 +++++++++++ vendors/Red-Black_Trees/PolySet.mli | 18 ++++++++++++++++++ 4 files changed, 37 insertions(+), 17 deletions(-) diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 04ebf8236..33fe71c80 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -622,18 +622,13 @@ let propagator_specialize1 : output_specialize1 propagator = (eqs, []) (* no new assignments *) let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments = - let mem elt set = match RedBlackTrees.PolySet.find_opt elt set with None -> false | Some _ -> true in fun selector propagator -> fun already_selected old_type_constraint dbs -> (* TODO: thread some state to know which selector outputs were already seen *) match selector old_type_constraint dbs with WasSelected selected_outputs -> - (* TODO: fold instead. *) - let (already_selected , selected_outputs) = - List.fold_left (fun (already_selected, selected_outputs) elt -> - if mem elt already_selected - then (RedBlackTrees.PolySet.add elt already_selected , elt :: selected_outputs) - else (already_selected , selected_outputs)) (already_selected , selected_outputs) selected_outputs in + let open RedBlackTrees.PolySet in + let { set = already_selected ; duplicates = _ ; added = selected_outputs } = add_list selected_outputs already_selected in (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index bd693942c..c42040854 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -29,7 +29,6 @@ module Substitution = struct ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env and s_type_environment : T.type_environment w = fun ~substs tenv -> bind_map_list (fun T.{type_variable ; type_} -> - let%bind type_variable = s_type_variable ~substs type_variable in let%bind type_ = s_type_expression ~substs type_ in ok @@ T.{type_variable ; type_}) tenv and s_environment : T.environment w = fun ~substs T.{expression_environment ; type_environment} -> @@ -45,14 +44,6 @@ module Substitution = struct let () = ignore @@ substs in ok var - and s_type_variable : T.type_variable w = fun ~substs tvar -> - let _TODO = ignore @@ substs in - Printf.printf "TODO: subst: unimplemented case s_type_variable"; - ok @@ tvar - (* if String.equal tvar v then - * expr - * else - * ok tvar *) and s_label : T.label w = fun ~substs l -> let () = ignore @@ substs in ok l @@ -71,7 +62,12 @@ module Substitution = struct ok @@ type_name and s_type_content : T.type_content w = fun ~substs -> function - | T.T_sum _ -> failwith "TODO: T_sum" + | T.T_sum s -> + let aux T.{ ctor_type; michelson_annotation ; ctor_decl_pos } = + let%bind ctor_type = s_type_expression ~substs ctor_type in + ok @@ T.{ ctor_type; michelson_annotation; ctor_decl_pos } in + let%bind s = Ast_typed.Helpers.bind_map_cmap aux s in + ok @@ T.T_sum s | T.T_record _ -> failwith "TODO: T_record" | T.T_constant type_name -> let%bind type_name = s_type_name_constant ~substs type_name in diff --git a/vendors/Red-Black_Trees/PolySet.ml b/vendors/Red-Black_Trees/PolySet.ml index ab26380f2..1dc3c12b0 100644 --- a/vendors/Red-Black_Trees/PolySet.ml +++ b/vendors/Red-Black_Trees/PolySet.ml @@ -23,6 +23,17 @@ let find elt set = let find_opt elt set = RB.find_opt ~cmp:set.cmp elt set.tree +let mem elt set = match RB.find_opt ~cmp:set.cmp elt set.tree with None -> false | Some _ -> true + +type 'a added = {set : 'a set; duplicates : 'a list; added : 'a list} + +let add_list elts set = + let aux = fun {set ; duplicates ; added} elt -> + if mem elt set + then {set; duplicates = elt :: duplicates ; added} + else {set = add elt set; duplicates; added = elt :: added} in + List.fold_left aux {set; duplicates=[]; added = []} elts + let elements set = RB.elements set.tree let iter f set = RB.iter f set.tree diff --git a/vendors/Red-Black_Trees/PolySet.mli b/vendors/Red-Black_Trees/PolySet.mli index c8eb4b6d4..589a1374b 100644 --- a/vendors/Red-Black_Trees/PolySet.mli +++ b/vendors/Red-Black_Trees/PolySet.mli @@ -46,10 +46,28 @@ val find : 'elt -> 'elt t -> 'elt val find_opt : 'elt -> 'elt t -> 'elt option +(* The value of the call [mem elt set] is [true] if there exists an + element [y] of set [set] such that [cmp y elt = true], where [cmp] + is the comparison function of [set] (see [create]). If [elt] is not + in [set], then [false] is returned instead. *) + +val mem : 'elt -> 'elt t -> bool + (* The value of the call [element set] is the list of elements of the set [set] in increasing order (with respect to the total comparison function used to create the set). *) +(* The value of the call [add_list element_list set] is a record of + type ['a added]. The elements from the [element_list] are added to + the [set] starting from the head of the list. The elements which + are already part of the [set] at the point at which they are added + are gathered in the [duplicates] list (and the [set] is not updated + for these elements, i.e. it keeps the pre-existing version of the + element). The elements which are not already members of the set are + added to the [set], and gathered in the [added] list. *) +type 'a added = {set : 'a set; duplicates : 'a list; added : 'a list} +val add_list : 'a list -> 'a set -> 'a added + val elements : 'elt t -> 'elt list (* The side-effect of evaluating the call [iter f set] is the From e2bf0f6466a412f38dfd03f7b642c1f7dbd864ae Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Thu, 28 May 2020 16:05:45 +0100 Subject: [PATCH 17/32] Split the solver into separate files, no meaningful changes to the code. --- src/passes/8-typer-new/README | 31 + .../8-typer-new/constraint_databases.ml | 69 ++ .../8-typer-new/heuristic_break_ctor.ml | 52 ++ .../8-typer-new/heuristic_specialize1.ml | 53 ++ src/passes/8-typer-new/normalizer.ml | 126 ++++ src/passes/8-typer-new/solver.ml | 690 +----------------- .../8-typer-new/solver_should_be_generated.ml | 214 ++++++ src/passes/8-typer-new/solver_types.ml | 18 + src/passes/8-typer-new/typelang.ml | 18 + src/passes/8-typer-new/typer.ml | 4 +- src/stages/4-ast_typed/ast_typed.ml | 1 + src/stages/4-ast_typed/types_utils.ml | 1 - 12 files changed, 603 insertions(+), 674 deletions(-) create mode 100644 src/passes/8-typer-new/README create mode 100644 src/passes/8-typer-new/constraint_databases.ml create mode 100644 src/passes/8-typer-new/heuristic_break_ctor.ml create mode 100644 src/passes/8-typer-new/heuristic_specialize1.ml create mode 100644 src/passes/8-typer-new/normalizer.ml create mode 100644 src/passes/8-typer-new/solver_should_be_generated.ml create mode 100644 src/passes/8-typer-new/solver_types.ml create mode 100644 src/passes/8-typer-new/typelang.ml diff --git a/src/passes/8-typer-new/README b/src/passes/8-typer-new/README new file mode 100644 index 000000000..a84d67214 --- /dev/null +++ b/src/passes/8-typer-new/README @@ -0,0 +1,31 @@ +Components: +* assignments (passive data structure). + Now: just a map from unification vars to types (pb: what about partial types?) + maybe just local assignments (allow only vars as children of pair(α,β)) +* constraint propagation: (buch of constraints) → (new constraints * assignments) + * sub-component: constraint selector (worklist / dynamic queries) + * sub-sub component: constraint normalizer: remove dupes and give structure + right now: union-find of unification vars + later: better database-like organisation of knowledge + * sub-sub component: lazy selector (don't re-try all selectors every time) + For now: just re-try everytime + * sub-component: propagation rule + For now: break pair(a, b) = pair(c, d) into a = c, b = d +* generalizer + For now: ? + +Workflow: + Start with empty assignments and structured database + Receive a new constraint + For each normalizer: + Use the pre-selector to see if it can be applied + Apply the normalizer, get some new items to insert in the structured database + For each propagator: + Use the selector to query the structured database and see if it can be applied + Apply the propagator, get some new constraints and assignments + Add the new assignments to the data structure. + + At some point (when?) + For each generalizer: + Use the generalizer's selector to see if it can be applied + Apply the generalizer to produce a new type, possibly with some ∀s injected diff --git a/src/passes/8-typer-new/constraint_databases.ml b/src/passes/8-typer-new/constraint_databases.ml new file mode 100644 index 000000000..8a121e11d --- /dev/null +++ b/src/passes/8-typer-new/constraint_databases.ml @@ -0,0 +1,69 @@ +module Map = RedBlackTrees.PolyMap +module UF = UnionFind.Poly2 +open Ast_typed.Types + +(* Light wrapper for API for grouped_by_variable in the structured + db, to access it modulo unification variable aliases. *) +let get_constraints_related_to : type_variable -> structured_dbs -> constraints = + fun variable dbs -> + let variable , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in + match Map.find_opt variable dbs.grouped_by_variable with + Some l -> l + | None -> { + constructor = [] ; + poly = [] ; + tc = [] ; + } +let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs = + fun variable c dbs -> + (* let (variable_repr , _height) , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in *) + let variable_repr , aliases = UF.get_or_set variable dbs.aliases in + let dbs = { dbs with aliases } in + let grouped_by_variable = Map.update variable_repr (function + None -> Some c + | Some (x : constraints) -> Some { + constructor = c.constructor @ x.constructor ; + poly = c.poly @ x.poly ; + tc = c.tc @ x.tc ; + }) + dbs.grouped_by_variable + in + let dbs = { dbs with grouped_by_variable } in + dbs + +let merge_constraints : type_variable -> type_variable -> structured_dbs -> structured_dbs = + fun variable_a variable_b dbs -> + (* get old representant for variable_a *) + let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in + let dbs = { dbs with aliases } in + (* get old representant for variable_b *) + let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in + let dbs = { dbs with aliases } in + + (* alias variable_a and variable_b together *) + let aliases = UF.alias variable_a variable_b dbs.aliases in + let dbs = { dbs with aliases } in + + (* Replace the two entries in grouped_by_variable by a single one *) + ( + let get_constraints ab = + match Map.find_opt ab dbs.grouped_by_variable with + | Some x -> x + | None -> { constructor = [] ; poly = [] ; tc = [] } in + let constraints_a = get_constraints variable_repr_a in + let constraints_b = get_constraints variable_repr_b in + let all_constraints = { + constructor = constraints_a.constructor @ constraints_b.constructor ; + poly = constraints_a.poly @ constraints_b.poly ; + tc = constraints_a.tc @ constraints_b.tc ; + } in + let grouped_by_variable = + Map.add variable_repr_a all_constraints dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + let grouped_by_variable = + Map.remove variable_repr_b dbs.grouped_by_variable in + let dbs = { dbs with grouped_by_variable} in + dbs + ) diff --git a/src/passes/8-typer-new/heuristic_break_ctor.ml b/src/passes/8-typer-new/heuristic_break_ctor.ml new file mode 100644 index 000000000..e676f2500 --- /dev/null +++ b/src/passes/8-typer-new/heuristic_break_ctor.ml @@ -0,0 +1,52 @@ +(* selector / propagation rule for breaking down composite types + * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) + +open Ast_typed.Misc +open Ast_typed.Types +open Solver_types + +let selector : (type_constraint_simpl, output_break_ctor) selector = + (* find two rules with the shape x = k(var …) and x = k'(var' …) *) + fun type_constraint_simpl dbs -> + match type_constraint_simpl with + SC_Constructor c -> + (* finding other constraints related to the same type variable and + with the same sort of constraint (constructor vs. constructor) + is symmetric *) + let other_cs = (Constraint_databases.get_constraints_related_to c.tv dbs).constructor in + let other_cs = List.filter (fun (o : c_constructor_simpl) -> Var.equal c.tv o.tv) other_cs in + (* TODO double-check the conditions in the propagator, we had a + bug here because the selector was too permissive. *) + let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in + WasSelected cs_pairs + | SC_Alias _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) + | SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) + | SC_Typeclass _ -> WasNotSelected + +let propagator : output_break_ctor propagator = + fun selected dbs -> + let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) + let a = selected.a_k_var in + let b = selected.a_k'_var' in + + (* The selector is expected to provice two constraints with the shape x = k(var …) and x = k'(var' …) *) + assert (Var.equal (a : c_constructor_simpl).tv (b : c_constructor_simpl).tv); + + (* produce constraints: *) + + (* a.tv = b.tv *) + let eq1 = c_equation { tsrc = "solver: propagator: break_ctor a" ; t = P_variable a.tv} { tsrc = "solver: propagator: break_ctor b" ; t = P_variable b.tv} "propagator: break_ctor" in + (* a.c_tag = b.c_tag *) + if (Solver_should_be_generated.compare_simple_c_constant a.c_tag b.c_tag) <> 0 then + failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" + Solver_should_be_generated.debug_pp_c_constructor_simpl a + Solver_should_be_generated.debug_pp_c_constructor_simpl b + (Solver_should_be_generated.compare_simple_c_constant a.c_tag b.c_tag)) + else + (* a.tv_list = b.tv_list *) + if List.length a.tv_list <> List.length b.tv_list then + failwith "type error: incompatible types, not same length" + else + let eqs3 = List.map2 (fun aa bb -> c_equation { tsrc = "solver: propagator: break_ctor aa" ; t = P_variable aa} { tsrc = "solver: propagator: break_ctor bb" ; t = P_variable bb} "propagator: break_ctor") a.tv_list b.tv_list in + let eqs = eq1 :: eqs3 in + (eqs , []) (* no new assignments *) diff --git a/src/passes/8-typer-new/heuristic_specialize1.ml b/src/passes/8-typer-new/heuristic_specialize1.ml new file mode 100644 index 000000000..6e481fc12 --- /dev/null +++ b/src/passes/8-typer-new/heuristic_specialize1.ml @@ -0,0 +1,53 @@ +(* selector / propagation rule for specializing polymorphic types + * For now: (x = forall y, z) and (x = k'(var' …)) + * produces the new constraint (z[x |-> k'(var' …)]) + * where [from |-> to] denotes substitution. *) + +module Core = Typesystem.Core +open Ast_typed.Misc +open Ast_typed.Types +open Solver_types + +let selector : (type_constraint_simpl, output_specialize1) selector = + (* find two rules with the shape (x = forall b, d) and x = k'(var' …) or vice versa *) + (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) + (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) + fun type_constraint_simpl dbs -> + match type_constraint_simpl with + SC_Constructor c -> + (* vice versa *) + let other_cs = (Constraint_databases.get_constraints_related_to c.tv dbs).poly in + let other_cs = List.filter (fun (x : c_poly_simpl) -> Var.equal c.tv x.tv) other_cs in + let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in + WasSelected cs_pairs + | SC_Alias _ -> WasNotSelected (* TODO: ??? *) + | SC_Poly p -> + let other_cs = (Constraint_databases.get_constraints_related_to p.tv dbs).constructor in + let other_cs = List.filter (fun (x : c_constructor_simpl) -> Var.equal x.tv p.tv) other_cs in + let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in + WasSelected cs_pairs + | SC_Typeclass _ -> WasNotSelected + +let propagator : output_specialize1 propagator = + fun selected dbs -> + let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) + let a = selected.poly in + let b = selected.a_k_var in + + (* The selector is expected to provide two constraints with the shape (x = forall y, z) and x = k'(var' …) *) + assert (Var.equal (a : c_poly_simpl).tv (b : c_constructor_simpl).tv); + + (* produce constraints: *) + + (* create a fresh existential variable to instantiate the polymorphic type y *) + let fresh_existential = Core.fresh_type_variable () in + (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential]) + The substitution is obtained by immediately applying the forall. *) + let apply = { + tsrc = "solver: propagator: specialize1 apply" ; + t = P_apply { tf = { tsrc = "solver: propagator: specialize1 tf" ; t = P_forall a.forall }; + targ = { tsrc = "solver: propagator: specialize1 targ" ; t = P_variable fresh_existential }} } in + let (reduced, new_constraints) = Typelang.check_applied @@ Typelang.type_level_eval apply in + let eq1 = c_equation { tsrc = "solver: propagator: specialize1 eq1" ; t = P_variable b.tv } reduced "propagator: specialize1" in + let eqs = eq1 :: new_constraints in + (eqs, []) (* no new assignments *) diff --git a/src/passes/8-typer-new/normalizer.ml b/src/passes/8-typer-new/normalizer.ml new file mode 100644 index 000000000..8c391c2d5 --- /dev/null +++ b/src/passes/8-typer-new/normalizer.ml @@ -0,0 +1,126 @@ +module Core = Typesystem.Core +module Map = RedBlackTrees.PolyMap +open Ast_typed.Misc +open Ast_typed.Types +open Solver_types + +(* sub-sub component: constraint normalizer: remove dupes and give structure + * right now: union-find of unification vars + * later: better database-like organisation of knowledge *) + +(* Each normalizer returns an updated database (after storing the + incoming constraint) and a list of constraints, used when the + normalizer rewrites the constraints e.g. into simpler ones. *) +(* TODO: If implemented in a language with decent sets, should be 'b set not 'b list. *) +type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list) + +(** Updates the dbs.all_constraints field when new constraints are + discovered. + + This field contains a list of all the constraints, without any form of + grouping or sorting. *) +let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + ({ dbs with all_constraints = new_constraint :: dbs.all_constraints } , [new_constraint]) + +(** Updates the dbs.grouped_by_variable field when new constraints are + discovered. + + This field contains a map from type variables to lists of + constraints that are related to that variable (in other words, the + key appears in the equation). + *) +let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + let store_constraint tvars constraints = + let aux dbs (tvar : type_variable) = + Constraint_databases.add_constraints_related_to tvar constraints dbs + in List.fold_left aux dbs tvars + in + let dbs = match new_constraint with + SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []} + | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]} + | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []} + | SC_Alias { a; b } -> Constraint_databases.merge_constraints a b dbs + in (dbs , [new_constraint]) + +(** Stores the first assinment ('a = ctor('b, …)) that is encountered. + + Subsequent ('a = ctor('b2, …)) with the same 'a are ignored. + + TOOD: are we checking somewhere that 'b … = 'b2 … ? *) +let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + match new_constraint with + | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) -> + let assignments = Map.update tv (function None -> Some c | e -> e) dbs.assignments in + let dbs = {dbs with assignments} in + (dbs , [new_constraint]) + | _ -> + (dbs , [new_constraint]) + +(* TODO: at some point there may be uses of named type aliases (type + foo = int; let x : foo = 42). These should be inlined. *) + +(** This function converts constraints from type_constraint to + type_constraint_simpl. The former has more possible cases, and the + latter uses a more minimalistic constraint language. + + It does not modify the dbs, and only rewrites the constraint + + TODO: update the code to show that the dbs are always copied as-is + *) +let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = + fun dbs new_constraint -> + let insert_fresh a b = + let fresh = Core.fresh_type_variable () in + let (dbs , cs1) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 1" ; t = P_variable fresh } a "normalizer: simpl 1") in + let (dbs , cs2) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 2" ; t = P_variable fresh } b "normalizer: simpl 2") in + (dbs , cs1 @ cs2) in + let split_constant a c_tag args = + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split_constant" ; t = P_variable v } t "normalizer: split_constant") (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in + (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars;reason_constr_simpl=Format.asprintf "normalizer: split constant %a = %a (%a)" Var.pp a Ast_typed.PP_generic.constant_tag c_tag (PP_helpers.list_sep Ast_typed.PP_generic.type_value (fun ppf () -> Format.fprintf ppf ", ")) args}] @ List.flatten recur) in + let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall ; reason_poly_simpl="normalizer: gather_forall"}]) in + let gather_alias a b = (dbs , [SC_Alias { a ; b ; reason_alias_simpl="normalizer: gather_alias"}]) in + let reduce_type_app a b = + let (reduced, new_constraints) = Typelang.check_applied @@ Typelang.type_level_eval b in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in + let (dbs , resimpl) = normalizer_simpl dbs (c_equation a reduced "normalizer: reduce_type_app") in (* Note: this calls recursively but cant't fall in the same case. *) + (dbs , resimpl @ List.flatten recur) in + let split_typeclass args tc = + let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in + let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split typeclass" ; t = P_variable v} t "normalizer: split_typeclass") (List.combine fresh_vars args) in + let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in + (dbs, [SC_Typeclass { tc ; args = fresh_vars ; reason_typeclass_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in + + match new_constraint.c with + (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) + | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b + (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) + | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b + (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) + | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b + (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) + | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b + | C_equation {aval={ tsrc = _ ; t = P_forall forall }; bval={ tsrc = _ ; t = P_variable b }} -> gather_forall b forall + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_forall forall }} -> gather_forall a forall + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_variable b }} -> gather_alias a b + | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_constant { p_ctor_tag; p_ctor_args } }} -> split_constant a p_ctor_tag p_ctor_args + | C_equation {aval={ tsrc = _ ; t = P_constant {p_ctor_tag; p_ctor_args} }; bval={ tsrc = _ ; t = P_variable b }} -> split_constant b p_ctor_tag p_ctor_args + (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) + | C_equation {aval=(_ as a); bval=({ tsrc = _ ; t = P_apply _ } as b)} -> reduce_type_app a b + | C_equation {aval=({ tsrc = _ ; t = P_apply _ } as a); bval=(_ as b)} -> reduce_type_app b a + (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) + | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass + | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *) + +let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad = + fun new_constraint dbs -> + (fun x -> x) + @@ lift normalizer_grouped_by_variable + @@ lift normalizer_assignments + @@ lift normalizer_all_constraints + @@ lift normalizer_simpl + @@ lift_state_list_monad ~state:dbs ~list:[new_constraint] diff --git a/src/passes/8-typer-new/solver.ml b/src/passes/8-typer-new/solver.ml index 33fe71c80..0bcbe1260 100644 --- a/src/passes/8-typer-new/solver.ml +++ b/src/passes/8-typer-new/solver.ml @@ -1,634 +1,24 @@ open Trace - module Core = Typesystem.Core module Map = RedBlackTrees.PolyMap module Set = RedBlackTrees.PolySet module UF = UnionFind.Poly2 - -module Wrap = Wrap -open Wrap -open Ast_typed.Misc - -(* TODO: remove this, it's not used anymore *) -module TypeVariable = -struct - type t = Core.type_variable - let compare a b = Var.compare a b - let to_string = (fun s -> Format.asprintf "%a" Var.pp s) - -end - - - -(* - -Components: -* assignments (passive data structure). - Now: just a map from unification vars to types (pb: what about partial types?) - maybe just local assignments (allow only vars as children of pair(α,β)) -* constraint propagation: (buch of constraints) → (new constraints * assignments) - * sub-component: constraint selector (worklist / dynamic queries) - * sub-sub component: constraint normalizer: remove dupes and give structure - right now: union-find of unification vars - later: better database-like organisation of knowledge - * sub-sub component: lazy selector (don't re-try all selectors every time) - For now: just re-try everytime - * sub-component: propagation rule - For now: break pair(a, b) = pair(c, d) into a = c, b = d -* generalizer - For now: ? - -Workflow: - Start with empty assignments and structured database - Receive a new constraint - For each normalizer: - Use the pre-selector to see if it can be applied - Apply the normalizer, get some new items to insert in the structured database - For each propagator: - Use the selector to query the structured database and see if it can be applied - Apply the propagator, get some new constraints and assignments - Add the new assignments to the data structure. - - At some point (when?) - For each generalizer: - Use the generalizer's selector to see if it can be applied - Apply the generalizer to produce a new type, possibly with some ∀s injected - -*) - open Ast_typed.Types - -module UnionFindWrapper = struct - (* Light wrapper for API for grouped_by_variable in the structured - db, to access it modulo unification variable aliases. *) - let get_constraints_related_to : type_variable -> structured_dbs -> constraints = - fun variable dbs -> - let variable , aliases = UF.get_or_set variable dbs.aliases in - let dbs = { dbs with aliases } in - match Map.find_opt variable dbs.grouped_by_variable with - Some l -> l - | None -> { - constructor = [] ; - poly = [] ; - tc = [] ; - } - let add_constraints_related_to : type_variable -> constraints -> structured_dbs -> structured_dbs = - fun variable c dbs -> - (* let (variable_repr , _height) , aliases = UF.get_or_set variable dbs.aliases in - let dbs = { dbs with aliases } in *) - let variable_repr , aliases = UF.get_or_set variable dbs.aliases in - let dbs = { dbs with aliases } in - let grouped_by_variable = Map.update variable_repr (function - None -> Some c - | Some (x : constraints) -> Some { - constructor = c.constructor @ x.constructor ; - poly = c.poly @ x.poly ; - tc = c.tc @ x.tc ; - }) - dbs.grouped_by_variable - in - let dbs = { dbs with grouped_by_variable } in - dbs - - let merge_constraints : type_variable -> type_variable -> structured_dbs -> structured_dbs = - fun variable_a variable_b dbs -> - (* get old representant for variable_a *) - let variable_repr_a , aliases = UF.get_or_set variable_a dbs.aliases in - let dbs = { dbs with aliases } in - (* get old representant for variable_b *) - let variable_repr_b , aliases = UF.get_or_set variable_b dbs.aliases in - let dbs = { dbs with aliases } in - - (* alias variable_a and variable_b together *) - let aliases = UF.alias variable_a variable_b dbs.aliases in - let dbs = { dbs with aliases } in - - (* Replace the two entries in grouped_by_variable by a single one *) - ( - let get_constraints ab = - match Map.find_opt ab dbs.grouped_by_variable with - | Some x -> x - | None -> { constructor = [] ; poly = [] ; tc = [] } in - let constraints_a = get_constraints variable_repr_a in - let constraints_b = get_constraints variable_repr_b in - let all_constraints = { - constructor = constraints_a.constructor @ constraints_b.constructor ; - poly = constraints_a.poly @ constraints_b.poly ; - tc = constraints_a.tc @ constraints_b.tc ; - } in - let grouped_by_variable = - Map.add variable_repr_a all_constraints dbs.grouped_by_variable in - let dbs = { dbs with grouped_by_variable} in - let grouped_by_variable = - Map.remove variable_repr_b dbs.grouped_by_variable in - let dbs = { dbs with grouped_by_variable} in - dbs - ) -end - -(* sub-sub component: constraint normalizer: remove dupes and give structure - * right now: union-find of unification vars - * later: better database-like organisation of knowledge *) - -(* Each normalizer returns an updated database (after storing the - incoming constraint) and a list of constraints, used when the - normalizer rewrites the constraints e.g. into simpler ones. *) -(* TODO: If implemented in a language with decent sets, should be 'b set not 'b list. *) -type ('a , 'b) normalizer = structured_dbs -> 'a -> (structured_dbs * 'b list) - -(** Updates the dbs.all_constraints field when new constraints are - discovered. - - This field contains a list of all the constraints, without any form of - grouping or sorting. *) -let normalizer_all_constraints : (type_constraint_simpl , type_constraint_simpl) normalizer = - fun dbs new_constraint -> - ({ dbs with all_constraints = new_constraint :: dbs.all_constraints } , [new_constraint]) - -(** Updates the dbs.grouped_by_variable field when new constraints are - discovered. - - This field contains a map from type variables to lists of - constraints that are related to that variable (in other words, the - key appears in the equation). - *) -let normalizer_grouped_by_variable : (type_constraint_simpl , type_constraint_simpl) normalizer = - fun dbs new_constraint -> - let store_constraint tvars constraints = - let aux dbs (tvar : type_variable) = - UnionFindWrapper.add_constraints_related_to tvar constraints dbs - in List.fold_left aux dbs tvars - in - let dbs = match new_constraint with - SC_Constructor ({tv ; c_tag = _ ; tv_list} as c) -> store_constraint (tv :: tv_list) {constructor = [c] ; poly = [] ; tc = []} - | SC_Typeclass ({tc = _ ; args} as c) -> store_constraint args {constructor = [] ; poly = [] ; tc = [c]} - | SC_Poly ({tv; forall = _} as c) -> store_constraint [tv] {constructor = [] ; poly = [c] ; tc = []} - | SC_Alias { a; b } -> UnionFindWrapper.merge_constraints a b dbs - in (dbs , [new_constraint]) - -(** Stores the first assinment ('a = ctor('b, …)) that is encountered. - - Subsequent ('a = ctor('b2, …)) with the same 'a are ignored. - - TOOD: are we checking somewhere that 'b … = 'b2 … ? *) -let normalizer_assignments : (type_constraint_simpl , type_constraint_simpl) normalizer = - fun dbs new_constraint -> - match new_constraint with - | SC_Constructor ({tv ; c_tag = _ ; tv_list = _} as c) -> - let assignments = Map.update tv (function None -> Some c | e -> e) dbs.assignments in - let dbs = {dbs with assignments} in - (dbs , [new_constraint]) - | _ -> - (dbs , [new_constraint]) - -(** Evaluates a type-leval application. For now, only supports - immediate beta-reduction at the root of the type. *) -let type_level_eval : type_value -> type_value * type_constraint list = - fun tv -> Typesystem.Misc.Substitution.Pattern.eval_beta_root ~tv - -(** Checks that a type-level application has been fully reduced. For - now, only some simple cases like applications of `forall` - failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *) - | _ -> () - in x - -(* TODO: at some point there may be uses of named type aliases (type - foo = int; let x : foo = 42). These should be inlined. *) - -(** This function converts constraints from type_constraint to - type_constraint_simpl. The former has more possible cases, and the - latter uses a more minimalistic constraint language. - - It does not modify the dbs, and only rewrites the constraint - - TODO: update the code to show that the dbs are always copied as-is - *) -let rec normalizer_simpl : (type_constraint , type_constraint_simpl) normalizer = - fun dbs new_constraint -> - let insert_fresh a b = - let fresh = Core.fresh_type_variable () in - let (dbs , cs1) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 1" ; t = P_variable fresh } a "normalizer: simpl 1") in - let (dbs , cs2) = normalizer_simpl dbs (c_equation { tsrc = "solver: normalizer: simpl 2" ; t = P_variable fresh } b "normalizer: simpl 2") in - (dbs , cs1 @ cs2) in - let split_constant a c_tag args = - let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split_constant" ; t = P_variable v } t "normalizer: split_constant") (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs , [SC_Constructor {tv=a;c_tag;tv_list=fresh_vars;reason_constr_simpl=Format.asprintf "normalizer: split constant %a = %a (%a)" Var.pp a Ast_typed.PP_generic.constant_tag c_tag (PP_helpers.list_sep Ast_typed.PP_generic.type_value (fun ppf () -> Format.fprintf ppf ", ")) args}] @ List.flatten recur) in - let gather_forall a forall = (dbs , [SC_Poly { tv=a; forall ; reason_poly_simpl="normalizer: gather_forall"}]) in - let gather_alias a b = (dbs , [SC_Alias { a ; b ; reason_alias_simpl="normalizer: gather_alias"}]) in - let reduce_type_app a b = - let (reduced, new_constraints) = check_applied @@ type_level_eval b in - let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs new_constraints in - let (dbs , resimpl) = normalizer_simpl dbs (c_equation a reduced "normalizer: reduce_type_app") in (* Note: this calls recursively but cant't fall in the same case. *) - (dbs , resimpl @ List.flatten recur) in - let split_typeclass args tc = - let fresh_vars = List.map (fun _ -> Core.fresh_type_variable ()) args in - let fresh_eqns = List.map (fun (v,t) -> c_equation { tsrc = "solver: normalizer: split typeclass" ; t = P_variable v} t "normalizer: split_typeclass") (List.combine fresh_vars args) in - let (dbs , recur) = List.fold_map_acc normalizer_simpl dbs fresh_eqns in - (dbs, [SC_Typeclass { tc ; args = fresh_vars ; reason_typeclass_simpl="normalizer: split_typeclass"}] @ List.flatten recur) in - - match new_constraint.c with - (* break down (forall 'b, body = forall 'c, body') into ('a = forall 'b, body and 'a = forall 'c, body')) *) - | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b - (* break down (forall 'b, body = c(args)) into ('a = forall 'b, body and 'a = c(args)) *) - | C_equation {aval=({ tsrc = _ ; t = P_forall _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b - (* break down (c(args) = c'(args')) into ('a = c(args) and 'a = c'(args')) *) - | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_constant _ } as b)} -> insert_fresh a b - (* break down (c(args) = forall 'b, body) into ('a = c(args) and 'a = forall 'b, body) *) - | C_equation {aval=({ tsrc = _ ; t = P_constant _ } as a); bval=({ tsrc = _ ; t = P_forall _ } as b)} -> insert_fresh a b - | C_equation {aval={ tsrc = _ ; t = P_forall forall }; bval={ tsrc = _ ; t = P_variable b }} -> gather_forall b forall - | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_forall forall }} -> gather_forall a forall - | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_variable b }} -> gather_alias a b - | C_equation {aval={ tsrc = _ ; t = P_variable a }; bval={ tsrc = _ ; t = P_constant { p_ctor_tag; p_ctor_args } }} -> split_constant a p_ctor_tag p_ctor_args - | C_equation {aval={ tsrc = _ ; t = P_constant {p_ctor_tag; p_ctor_args} }; bval={ tsrc = _ ; t = P_variable b }} -> split_constant b p_ctor_tag p_ctor_args - (* Reduce the type-level application, and simplify the resulting constraint + the extra constraints (typeclasses) that appeared at the forall binding site *) - | C_equation {aval=(_ as a); bval=({ tsrc = _ ; t = P_apply _ } as b)} -> reduce_type_app a b - | C_equation {aval=({ tsrc = _ ; t = P_apply _ } as a); bval=(_ as b)} -> reduce_type_app b a - (* break down (TC(args)) into (TC('a, …) and ('a = arg) …) *) - | C_typeclass { tc_args; typeclass } -> split_typeclass tc_args typeclass - | C_access_label { c_access_label_tval; accessor; c_access_label_tvar } -> let _todo = ignore (c_access_label_tval, accessor, c_access_label_tvar) in failwith "TODO" (* tv, label, result *) - -(* Random notes from live discussion. Kept here to include bits as a rationale later on / remind me of the discussion in the short term. - * Feel free to erase if it rots here for too long. - * - * function (zetype, zevalue) { if (typeof(zevalue) != zetype) { ohlàlà; } else { return zevalue; } } - * - * let f = (fun {a : Type} (v : a) -> v) - * - * (forall 'a, 'a -> 'a) ~ (int -> int) - * (forall {a : Type}, forall (v : a), a) ~ (forall (v : int), int) - * ({a : Type} -> (v : a) -> a) ~ ((v : int) -> int) - * - * (@f int) - * - * - * 'c 'c - * 'd -> 'e && 'c ~ d && 'c ~ 'e - * 'c -> 'c ???????????????wtf---->???????????? [ scope of 'c is fun z ] - * 'tid ~ (forall 'c, 'c -> 'c) - * let id = (fun z -> z) in - * let ii = (fun z -> z + 0) : (int -> int) in - * - * 'a 'b ['a ~ 'b] 'a 'b - * 'a 'a 'a 'a 'a - * (forall 'a, 'a -> 'a -> 'a ) 'tid 'tid - * - * 'tid -> 'tid -> 'tid - * - * (forall 'a, 'a -> 'a -> 'a ) (forall 'c1, 'c1 -> 'c1) (int -> int) - * (forall 'c1, 'c1 -> 'c1)~(int -> int) - * ('c1 -> 'c1) ~ (int -> int) - * (fun x y -> if random then x else y) id ii as toto - * id "foo" *) - -type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list } -let lift_state_list_monad ~state ~list = { state ; list } -let lift f = - fun { state ; list } -> - let (new_state , new_lists) = List.fold_map_acc f state list in - { state = new_state ; list = List.flatten new_lists } - -(* TODO: move this to the List module *) -let named_fold_left f ~acc ~lst = List.fold_left (fun acc elt -> f ~acc ~elt) acc lst - -module Fun = struct let id x = x end (* in stdlib as of 4.08, we're in 4.07 for now *) - -let normalizers : type_constraint -> structured_dbs -> (structured_dbs , 'modified_constraint) state_list_monad = - fun new_constraint dbs -> - Fun.id - @@ lift normalizer_grouped_by_variable - @@ lift normalizer_assignments - @@ lift normalizer_all_constraints - @@ lift normalizer_simpl - @@ lift_state_list_monad ~state:dbs ~list:[new_constraint] +open Solver_types (* sub-sub component: lazy selector (don't re-try all selectors every time) * For now: just re-try everytime *) -type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *) -type 'selector_output selector_outputs = - WasSelected of 'selector_output list - | WasNotSelected -type new_constraints = type_constraint list -type new_assignments = c_constructor_simpl list - -type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs -type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments - -(* selector / propagation rule for breaking down composite types - * For now: break pair(a, b) = pair(c, d) into a = c, b = d *) - -let selector_break_ctor : (type_constraint_simpl, output_break_ctor) selector = - (* find two rules with the shape x = k(var …) and x = k'(var' …) *) - fun type_constraint_simpl dbs -> - match type_constraint_simpl with - SC_Constructor c -> - (* finding other constraints related to the same type variable and - with the same sort of constraint (constructor vs. constructor) - is symmetric *) - let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).constructor in - let other_cs = List.filter (fun (o : c_constructor_simpl) -> Var.equal c.tv o.tv) other_cs in - (* TODO double-check the conditions in the propagator, we had a - bug here because the selector was too permissive. *) - let cs_pairs = List.map (fun x -> { a_k_var = c ; a_k'_var' = x }) other_cs in - WasSelected cs_pairs - | SC_Alias _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) - | SC_Poly _ -> WasNotSelected (* TODO: ??? (beware: symmetry) *) - | SC_Typeclass _ -> WasNotSelected - -(* TODO: move this to a more appropriate place and/or auto-generate it. *) -let compare_simple_c_constant = function - | C_arrow -> (function - (* N/A -> 1 *) - | C_arrow -> 0 - | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_option -> (function - | C_arrow -> 1 - | C_option -> 0 - | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_record -> (function - | C_arrow | C_option -> 1 - | C_record -> 0 - | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_variant -> (function - | C_arrow | C_option | C_record -> 1 - | C_variant -> 0 - | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_map -> (function - | C_arrow | C_option | C_record | C_variant -> 1 - | C_map -> 0 - | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_big_map -> (function - | C_arrow | C_option | C_record | C_variant | C_map -> 1 - | C_big_map -> 0 - | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_list -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1 - | C_list -> 0 - | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_set -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1 - | C_set -> 0 - | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_unit -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 - | C_unit -> 0 - | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_string -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 - | C_string -> 0 - | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_nat -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string -> 1 - | C_nat -> 0 - | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_mutez -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat -> 1 - | C_mutez -> 0 - | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_timestamp -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez -> 1 - | C_timestamp -> 0 - | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_int -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp -> 1 - | C_int -> 0 - | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_address -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1 - | C_address -> 0 - | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_bytes -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1 - | C_bytes -> 0 - | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_key_hash -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1 - | C_key_hash -> 0 - | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_key -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 - | C_key -> 0 - | C_signature | C_operation | C_contract | C_chain_id -> -1) - | C_signature -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 - | C_signature -> 0 - | C_operation | C_contract | C_chain_id -> -1) - | C_operation -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 - | C_operation -> 0 - | C_contract | C_chain_id -> -1) - | C_contract -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 - | C_contract -> 0 - | C_chain_id -> -1) - | C_chain_id -> (function - | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1 - | C_chain_id -> 0 - (* N/A -> -1 *) - ) - -(* Using a pretty-printer from the PP.ml module creates a dependency - loop, so the one that we need temporarily for debugging purposes - has been copied here. *) -let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag -> - let ct = match c_tag with - | T.C_arrow -> "arrow" - | T.C_option -> "option" - | T.C_record -> failwith "record" - | T.C_variant -> failwith "variant" - | T.C_map -> "map" - | T.C_big_map -> "big_map" - | T.C_list -> "list" - | T.C_set -> "set" - | T.C_unit -> "unit" - | T.C_string -> "string" - | T.C_nat -> "nat" - | T.C_mutez -> "mutez" - | T.C_timestamp -> "timestamp" - | T.C_int -> "int" - | T.C_address -> "address" - | T.C_bytes -> "bytes" - | T.C_key_hash -> "key_hash" - | T.C_key -> "key" - | T.C_signature -> "signature" - | T.C_operation -> "operation" - | T.C_contract -> "contract" - | T.C_chain_id -> "chain_id" - in - Format.fprintf ppf "%s" ct - -let debug_pp_c_constructor_simpl ppf { tv; c_tag; tv_list } = - Format.fprintf ppf "CTOR %a %a(%a)" Var.pp tv debug_pp_constant c_tag PP_helpers.(list_sep Var.pp (const " , ")) tv_list - -let propagator_break_ctor : output_break_ctor propagator = - fun selected dbs -> - let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) - let a = selected.a_k_var in - let b = selected.a_k'_var' in - - (* The selector is expected to provice two constraints with the shape x = k(var …) and x = k'(var' …) *) - assert (Var.equal (a : c_constructor_simpl).tv (b : c_constructor_simpl).tv); - - (* produce constraints: *) - - (* a.tv = b.tv *) - let eq1 = c_equation { tsrc = "solver: propagator: break_ctor a" ; t = P_variable a.tv} { tsrc = "solver: propagator: break_ctor b" ; t = P_variable b.tv} "propagator: break_ctor" in - (* a.c_tag = b.c_tag *) - if (compare_simple_c_constant a.c_tag b.c_tag) <> 0 then - failwith (Format.asprintf "type error: incompatible types, not same ctor %a vs. %a (compare returns %d)" debug_pp_c_constructor_simpl a debug_pp_c_constructor_simpl b (compare_simple_c_constant a.c_tag b.c_tag)) - else - (* a.tv_list = b.tv_list *) - if List.length a.tv_list <> List.length b.tv_list then - failwith "type error: incompatible types, not same length" - else - let eqs3 = List.map2 (fun aa bb -> c_equation { tsrc = "solver: propagator: break_ctor aa" ; t = P_variable aa} { tsrc = "solver: propagator: break_ctor bb" ; t = P_variable bb} "propagator: break_ctor") a.tv_list b.tv_list in - let eqs = eq1 :: eqs3 in - (eqs , []) (* no new assignments *) - (* TODO : with our selectors, the selection depends on the order in which the constraints are added :-( :-( :-( :-( We need to return a lazy stream of constraints. *) - - -let ( (function - [] -> 1 - | hd2::tl2 -> - f hd1 hd2 - compare_list f tl1 tl2) - | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) -let compare_type_variable a b = - Var.compare a b -let compare_label (a:label) (b:label) = - let Label a = a in - let Label b = b in - String.compare a b -let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b -and compare_type_expression { tsrc = _ ; t = ta } { tsrc = _ ; t = tb } = - (* Note: this comparison ignores the tsrc, the idea is that types - will often be compared to see if they are the same, regardless of - where the type comes from .*) - compare_type_expression_ ta tb -and compare_type_expression_ = function - | P_forall { binder=a1; constraints=a2; body=a3 } -> (function - | P_forall { binder=b1; constraints=b2; body=b3 } -> - compare_type_variable a1 b1 - compare_list compare_type_constraint a2 b2 - compare_type_expression a3 b3 - | P_variable _ -> -1 - | P_constant _ -> -1 - | P_apply _ -> -1) - | P_variable a -> (function - | P_forall _ -> 1 - | P_variable b -> compare_type_variable a b - | P_constant _ -> -1 - | P_apply _ -> -1) - | P_constant { p_ctor_tag=a1; p_ctor_args=a2 } -> (function - | P_forall _ -> 1 - | P_variable _ -> 1 - | P_constant { p_ctor_tag=b1; p_ctor_args=b2 } -> compare_simple_c_constant a1 b1 compare_list compare_type_expression a2 b2 - | P_apply _ -> -1) - | P_apply { tf=a1; targ=a2 } -> (function - | P_forall _ -> 1 - | P_variable _ -> 1 - | P_constant _ -> 1 - | P_apply { tf=b1; targ=b2 } -> compare_type_expression a1 b1 compare_type_expression a2 b2) -and compare_type_constraint = fun { c = ca ; reason = ra } { c = cb ; reason = rb } -> - let c = compare_type_constraint_ ca cb in - if c < 0 then -1 - else if c = 0 then String.compare ra rb - else 1 -and compare_type_constraint_ = function - | C_equation { aval=a1; bval=a2 } -> (function - | C_equation { aval=b1; bval=b2 } -> compare_type_expression a1 b1 compare_type_expression a2 b2 - | C_typeclass _ -> -1 - | C_access_label _ -> -1) - | C_typeclass { tc_args=a1; typeclass=a2 } -> (function - | C_equation _ -> 1 - | C_typeclass { tc_args=b1; typeclass=b2 } -> compare_list compare_type_expression a1 b1 compare_typeclass a2 b2 - | C_access_label _ -> -1) - | C_access_label { c_access_label_tval=a1; accessor=a2; c_access_label_tvar=a3 } -> (function - | C_equation _ -> 1 - | C_typeclass _ -> 1 - | C_access_label { c_access_label_tval=b1; accessor=b2; c_access_label_tvar=b3 } -> compare_type_expression a1 b1 compare_label a2 b2 compare_type_variable a3 b3) -let compare_type_constraint_list = compare_list compare_type_constraint -let compare_p_forall - { binder = a1; constraints = a2; body = a3 } - { binder = b1; constraints = b2; body = b3 } = - compare_type_variable a1 b1 - compare_type_constraint_list a2 b2 - compare_type_expression a3 b3 -let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = - compare_type_variable a1 b1 - compare_p_forall a2 b2 -let compare_c_constructor_simpl { reason_constr_simpl = _ ; tv=a1; c_tag=a2; tv_list=a3 } { reason_constr_simpl = _ ; tv=b1; c_tag=b2; tv_list=b3 } = - (* We do not compare the reasons, as they are only for debugging and - not part of the type *) - compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 - -let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = - compare_c_poly_simpl a1 b1 - compare_c_constructor_simpl a2 b2 - -let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = - compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 - -let selector_specialize1 : (type_constraint_simpl, output_specialize1) selector = - (* find two rules with the shape (x = forall b, d) and x = k'(var' …) or vice versa *) - (* TODO: do the same for two rules with the shape (a = forall b, d) and tc(a…) *) - (* TODO: do the appropriate thing for two rules with the shape (a = forall b, d) and (a = forall b', d') *) - fun type_constraint_simpl dbs -> - match type_constraint_simpl with - SC_Constructor c -> - (* vice versa *) - let other_cs = (UnionFindWrapper.get_constraints_related_to c.tv dbs).poly in - let other_cs = List.filter (fun (x : c_poly_simpl) -> Var.equal c.tv x.tv) other_cs in - let cs_pairs = List.map (fun x -> { poly = x ; a_k_var = c }) other_cs in - WasSelected cs_pairs - | SC_Alias _ -> WasNotSelected (* TODO: ??? *) - | SC_Poly p -> - let other_cs = (UnionFindWrapper.get_constraints_related_to p.tv dbs).constructor in - let other_cs = List.filter (fun (x : c_constructor_simpl) -> Var.equal x.tv p.tv) other_cs in - let cs_pairs = List.map (fun x -> { poly = p ; a_k_var = x }) other_cs in - WasSelected cs_pairs - | SC_Typeclass _ -> WasNotSelected - -let propagator_specialize1 : output_specialize1 propagator = - fun selected dbs -> - let () = ignore (dbs) in (* this propagator doesn't need to use the dbs *) - let a = selected.poly in - let b = selected.a_k_var in - - (* The selector is expected to provice two constraints with the shape (x = forall y, z) and x = k'(var' …) *) - assert (Var.equal (a : c_poly_simpl).tv (b : c_constructor_simpl).tv); - - (* produce constraints: *) - - (* create a fresh existential variable to instantiate the polymorphic type y *) - let fresh_existential = Core.fresh_type_variable () in - (* Produce the constraint (b.tv = a.body[a.binder |-> fresh_existential]) - The substitution is obtained by immediately applying the forall. *) - let apply = { tsrc = "solver: propagator: specialize1 apply" ; t = P_apply {tf = { tsrc = "solver: propagator: specialize1 tf" ; t = P_forall a.forall }; targ = { tsrc = "solver: propagator: specialize1 targ" ; t = P_variable fresh_existential }} } in - let (reduced, new_constraints) = check_applied @@ type_level_eval apply in - let eq1 = c_equation { tsrc = "solver: propagator: specialize1 eq1" ; t = P_variable b.tv } reduced "propagator: specialize1" in - let eqs = eq1 :: new_constraints in - (eqs, []) (* no new assignments *) - let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagator -> _ -> 'a -> structured_dbs -> _ * new_constraints * new_assignments = fun selector propagator -> fun already_selected old_type_constraint dbs -> (* TODO: thread some state to know which selector outputs were already seen *) match selector old_type_constraint dbs with WasSelected selected_outputs -> - let open RedBlackTrees.PolySet in - let { set = already_selected ; duplicates = _ ; added = selected_outputs } = add_list selected_outputs already_selected in + let Set.{ set = already_selected ; duplicates = _ ; added = selected_outputs } = Set.add_list selected_outputs already_selected in (* Call the propagation rule *) let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in @@ -637,8 +27,9 @@ let select_and_propagate : ('old_input, 'selector_output) selector -> _ propagat | WasNotSelected -> (already_selected, [] , []) -let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor -let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 +(* TODO: put the heuristics with their state in a list. *) +let select_and_propagate_break_ctor = select_and_propagate Heuristic_break_ctor.selector Heuristic_break_ctor.propagator +let select_and_propagate_specialize1 = select_and_propagate Heuristic_specialize1.selector Heuristic_specialize1.propagator (* Takes a constraint, applies all selector+propagator pairs to it. Keeps track of which constraints have already been selected. *) @@ -671,7 +62,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s match new_constraints with | [] -> (already_selected, dbs) | new_constraint :: tl -> - let { state = dbs ; list = modified_constraints } = normalizers new_constraint dbs in + let { state = dbs ; list = modified_constraints } = Normalizer.normalizers new_constraint dbs in let (already_selected , new_constraints' , dbs) = List.fold_left (fun (already_selected , nc , dbs) c -> @@ -686,42 +77,22 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s (* constraint propagation: (buch of constraints) → (new constraints * assignments) *) - - - - (* Below is a draft *) -(* type state = { - * (\* when α-renaming x to y, we put them in the same union-find class *\) - * unification_vars : unionfind ; - * - * (\* assigns a value to the representant in the unionfind *\) - * assignments : type_expression TypeVariableMap.t ; - * - * (\* constraints related to a type variable *\) - * constraints : constraints TypeVariableMap.t ; - * } *) - -let initial_state : typer_state = (* { - * unification_vars = UF.empty ; - * constraints = TypeVariableMap.empty ; - * assignments = TypeVariableMap.empty ; - * } *) -{ - structured_dbs = - { - all_constraints = [] ; (* type_constraint_simpl list *) - aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare ; (* unionfind *) - assignments = Map.create ~cmp:Var.compare; (* c_constructor_simpl TypeVariableMap.t *) - grouped_by_variable = Map.create ~cmp:Var.compare; (* constraints TypeVariableMap.t *) - cycle_detection_toposort = (); (* unit *) - } ; - already_selected = { - break_ctor = Set.create ~cmp:compare_output_break_ctor; - specialize1 = Set.create ~cmp:compare_output_specialize1 ; +let initial_state : typer_state = { + structured_dbs = + { + all_constraints = ([] : type_constraint_simpl list) ; + aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare; + assignments = (Map.create ~cmp:Var.compare : (type_variable, c_constructor_simpl) Map.t); + grouped_by_variable = (Map.create ~cmp:Var.compare : (type_variable, constraints) Map.t); + cycle_detection_toposort = (); + } ; + already_selected = { + break_ctor = Set.create ~cmp:Solver_should_be_generated.compare_output_break_ctor; + specialize1 = Set.create ~cmp:Solver_should_be_generated.compare_output_specialize1 ; + } } -} (* This function is called when a program is fully compiled, and the typechecker's state is discarded. TODO: either get rid of the state @@ -732,23 +103,6 @@ let initial_state : typer_state = (* { state any further. Suzanne *) let discard_state (_ : typer_state) = () -(* let replace_var_in_state = fun (v : type_variable) (state : state) -> *) -(* let aux_tv : type_expression -> _ = function *) -(* | P_forall (w , cs , tval) -> failwith "TODO" *) -(* | P_variable (w) -> *) -(* if w = v then *) -(* (*…*) *) -(* else *) -(* (*…*) *) -(* | P_constant (c , args) -> failwith "TODO" *) -(* | P_access_label (tv , label) -> failwith "TODO" in *) -(* let aux_tc tc = *) -(* List.map (fun l -> List.map aux_tv l) tc in *) -(* let aux : type_constraint -> _ = function *) -(* | C_equation (l , r) -> C_equation (aux_tv l , aux_tv r) *) -(* | C_typeclass (l , rs) -> C_typeclass (List.map aux_tv l , aux_tc rs) *) -(* in List.map aux state *) - (* This is the solver *) let aggregate_constraints : typer_state -> type_constraint list -> typer_state result = fun state newc -> (* TODO: Iterate over constraints *) @@ -758,12 +112,6 @@ let aggregate_constraints : typer_state -> type_constraint list -> typer_state r (*let { constraints ; eqv } = state in ok { constraints = constraints @ newc ; eqv }*) - - - - - - (* Later on, we'll ensure that all the heuristics register the existential/unification variables that they create, as well as the new constraints that they create. We will then check that they only diff --git a/src/passes/8-typer-new/solver_should_be_generated.ml b/src/passes/8-typer-new/solver_should_be_generated.ml new file mode 100644 index 000000000..91fc93b4a --- /dev/null +++ b/src/passes/8-typer-new/solver_should_be_generated.ml @@ -0,0 +1,214 @@ +(* The contents of this file should be auto-generated. *) + +open Ast_typed.Types +module T = Ast_typed.Types + +let compare_simple_c_constant = function + | C_arrow -> (function + (* N/A -> 1 *) + | C_arrow -> 0 + | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_option -> (function + | C_arrow -> 1 + | C_option -> 0 + | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_record -> (function + | C_arrow | C_option -> 1 + | C_record -> 0 + | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_variant -> (function + | C_arrow | C_option | C_record -> 1 + | C_variant -> 0 + | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_map -> (function + | C_arrow | C_option | C_record | C_variant -> 1 + | C_map -> 0 + | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_big_map -> (function + | C_arrow | C_option | C_record | C_variant | C_map -> 1 + | C_big_map -> 0 + | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_list -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map -> 1 + | C_list -> 0 + | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_set -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list -> 1 + | C_set -> 0 + | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_unit -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set -> 1 + | C_unit -> 0 + | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_string -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit -> 1 + | C_string -> 0 + | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_nat -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string -> 1 + | C_nat -> 0 + | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_mutez -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat -> 1 + | C_mutez -> 0 + | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_timestamp -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez -> 1 + | C_timestamp -> 0 + | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_int -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp -> 1 + | C_int -> 0 + | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_address -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int -> 1 + | C_address -> 0 + | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_bytes -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address -> 1 + | C_bytes -> 0 + | C_key_hash | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_key_hash -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes -> 1 + | C_key_hash -> 0 + | C_key | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_key -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash -> 1 + | C_key -> 0 + | C_signature | C_operation | C_contract | C_chain_id -> -1) + | C_signature -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key -> 1 + | C_signature -> 0 + | C_operation | C_contract | C_chain_id -> -1) + | C_operation -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature -> 1 + | C_operation -> 0 + | C_contract | C_chain_id -> -1) + | C_contract -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation -> 1 + | C_contract -> 0 + | C_chain_id -> -1) + | C_chain_id -> (function + | C_arrow | C_option | C_record | C_variant | C_map | C_big_map | C_list | C_set | C_unit | C_string | C_nat | C_mutez | C_timestamp | C_int | C_address | C_bytes | C_key_hash | C_key | C_signature | C_operation | C_contract -> 1 + | C_chain_id -> 0 + (* N/A -> -1 *) + ) + +let ( (function + [] -> 1 + | hd2::tl2 -> + f hd1 hd2 + compare_list f tl1 tl2) + | [] -> (function [] -> 0 | _::_ -> -1) (* This follows the behaviour of Pervasives.compare for lists of different length *) +let compare_type_variable a b = + Var.compare a b +let compare_label (a:label) (b:label) = + let Label a = a in + let Label b = b in + String.compare a b +let rec compare_typeclass a b = compare_list (compare_list compare_type_expression) a b +and compare_type_expression { tsrc = _ ; t = ta } { tsrc = _ ; t = tb } = + (* Note: this comparison ignores the tsrc, the idea is that types + will often be compared to see if they are the same, regardless of + where the type comes from .*) + compare_type_expression_ ta tb +and compare_type_expression_ = function + | P_forall { binder=a1; constraints=a2; body=a3 } -> (function + | P_forall { binder=b1; constraints=b2; body=b3 } -> + compare_type_variable a1 b1 + compare_list compare_type_constraint a2 b2 + compare_type_expression a3 b3 + | P_variable _ -> -1 + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_variable a -> (function + | P_forall _ -> 1 + | P_variable b -> compare_type_variable a b + | P_constant _ -> -1 + | P_apply _ -> -1) + | P_constant { p_ctor_tag=a1; p_ctor_args=a2 } -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant { p_ctor_tag=b1; p_ctor_args=b2 } -> compare_simple_c_constant a1 b1 compare_list compare_type_expression a2 b2 + | P_apply _ -> -1) + | P_apply { tf=a1; targ=a2 } -> (function + | P_forall _ -> 1 + | P_variable _ -> 1 + | P_constant _ -> 1 + | P_apply { tf=b1; targ=b2 } -> compare_type_expression a1 b1 compare_type_expression a2 b2) +and compare_type_constraint = fun { c = ca ; reason = ra } { c = cb ; reason = rb } -> + let c = compare_type_constraint_ ca cb in + if c < 0 then -1 + else if c = 0 then String.compare ra rb + else 1 +and compare_type_constraint_ = function + | C_equation { aval=a1; bval=a2 } -> (function + | C_equation { aval=b1; bval=b2 } -> compare_type_expression a1 b1 compare_type_expression a2 b2 + | C_typeclass _ -> -1 + | C_access_label _ -> -1) + | C_typeclass { tc_args=a1; typeclass=a2 } -> (function + | C_equation _ -> 1 + | C_typeclass { tc_args=b1; typeclass=b2 } -> compare_list compare_type_expression a1 b1 compare_typeclass a2 b2 + | C_access_label _ -> -1) + | C_access_label { c_access_label_tval=a1; accessor=a2; c_access_label_tvar=a3 } -> (function + | C_equation _ -> 1 + | C_typeclass _ -> 1 + | C_access_label { c_access_label_tval=b1; accessor=b2; c_access_label_tvar=b3 } -> compare_type_expression a1 b1 compare_label a2 b2 compare_type_variable a3 b3) +let compare_type_constraint_list = compare_list compare_type_constraint +let compare_p_forall + { binder = a1; constraints = a2; body = a3 } + { binder = b1; constraints = b2; body = b3 } = + compare_type_variable a1 b1 + compare_type_constraint_list a2 b2 + compare_type_expression a3 b3 +let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } = + compare_type_variable a1 b1 + compare_p_forall a2 b2 +let compare_c_constructor_simpl { reason_constr_simpl = _ ; tv=a1; c_tag=a2; tv_list=a3 } { reason_constr_simpl = _ ; tv=b1; c_tag=b2; tv_list=b3 } = + (* We do not compare the reasons, as they are only for debugging and + not part of the type *) + compare_type_variable a1 b1 compare_simple_c_constant a2 b2 compare_list compare_type_variable a3 b3 + +(* TODO: use Ast_typed.Compare_generic.output_specialize1 etc. but don't compare the reasons *) +let compare_output_specialize1 { poly = a1; a_k_var = a2 } { poly = b1; a_k_var = b2 } = + compare_c_poly_simpl a1 b1 + compare_c_constructor_simpl a2 b2 + +let compare_output_break_ctor { a_k_var=a1; a_k'_var'=a2 } { a_k_var=b1; a_k'_var'=b2 } = + compare_c_constructor_simpl a1 b1 compare_c_constructor_simpl a2 b2 + +(* Using a pretty-printer from the PP.ml module creates a dependency + loop, so the one that we need temporarily for debugging purposes + has been copied here. *) +let debug_pp_constant : _ -> constant_tag -> unit = fun ppf c_tag -> + let ct = match c_tag with + | T.C_arrow -> "arrow" + | T.C_option -> "option" + | T.C_record -> failwith "record" + | T.C_variant -> failwith "variant" + | T.C_map -> "map" + | T.C_big_map -> "big_map" + | T.C_list -> "list" + | T.C_set -> "set" + | T.C_unit -> "unit" + | T.C_string -> "string" + | T.C_nat -> "nat" + | T.C_mutez -> "mutez" + | T.C_timestamp -> "timestamp" + | T.C_int -> "int" + | T.C_address -> "address" + | T.C_bytes -> "bytes" + | T.C_key_hash -> "key_hash" + | T.C_key -> "key" + | T.C_signature -> "signature" + | T.C_operation -> "operation" + | T.C_contract -> "contract" + | T.C_chain_id -> "chain_id" + in + Format.fprintf ppf "%s" ct + +let debug_pp_c_constructor_simpl ppf { tv; c_tag; tv_list } = + Format.fprintf ppf "CTOR %a %a(%a)" Var.pp tv debug_pp_constant c_tag PP_helpers.(list_sep Var.pp (const " , ")) tv_list diff --git a/src/passes/8-typer-new/solver_types.ml b/src/passes/8-typer-new/solver_types.ml new file mode 100644 index 000000000..9690d9c0a --- /dev/null +++ b/src/passes/8-typer-new/solver_types.ml @@ -0,0 +1,18 @@ +open Ast_typed.Types + +type 'old_constraint_type selector_input = 'old_constraint_type (* some info about the constraint just added, so that we know what to look for *) +type 'selector_output selector_outputs = + WasSelected of 'selector_output list + | WasNotSelected +type new_constraints = type_constraint list +type new_assignments = c_constructor_simpl list +type ('old_constraint_type, 'selector_output) selector = 'old_constraint_type selector_input -> structured_dbs -> 'selector_output selector_outputs +type 'selector_output propagator = 'selector_output -> structured_dbs -> new_constraints * new_assignments + +(* state+list monad *) +type ('state, 'elt) state_list_monad = { state: 'state ; list : 'elt list } +let lift_state_list_monad ~state ~list = { state ; list } +let lift f = + fun { state ; list } -> + let (new_state , new_lists) = List.fold_map_acc f state list in + { state = new_state ; list = List.flatten new_lists } diff --git a/src/passes/8-typer-new/typelang.ml b/src/passes/8-typer-new/typelang.ml new file mode 100644 index 000000000..ac9c3faa3 --- /dev/null +++ b/src/passes/8-typer-new/typelang.ml @@ -0,0 +1,18 @@ +(* This file implements the type-level language. For now limited to + type constants, type functions and their application. *) + +open Ast_typed.Types + +(** Evaluates a type-leval application. For now, only supports + immediate beta-reduction at the root of the type. *) +let type_level_eval : type_value -> type_value * type_constraint list = + fun tv -> Typesystem.Misc.Substitution.Pattern.eval_beta_root ~tv + +(** Checks that a type-level application has been fully reduced. For + now, only some simple cases like applications of `forall` + failwith "internal error: shouldn't happen" (* failwith "could not reduce type-level application. Arbitrary type-level applications are not supported for now." *) + | _ -> () + in x diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 89f1183aa..604740583 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -416,11 +416,11 @@ and type_lambda e state { let%bind input_type' = bind_map_option (evaluate_type e) input_type in let%bind output_type' = bind_map_option (evaluate_type e) output_type in - let fresh : O.type_expression = t_variable (Solver.Wrap.fresh_binder ()) () in + let fresh : O.type_expression = t_variable (Wrap.fresh_binder ()) () in let e' = Environment.add_ez_binder (binder) fresh e in let%bind (result , state') = type_expression e' state result in - let wrapped = Solver.Wrap.lambda fresh input_type' output_type' result.type_expression in + let wrapped = Wrap.lambda fresh input_type' output_type' result.type_expression in ok (({binder;result}:O.lambda),state',wrapped) and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result = diff --git a/src/stages/4-ast_typed/ast_typed.ml b/src/stages/4-ast_typed/ast_typed.ml index 9a1250ecc..b97117f9c 100644 --- a/src/stages/4-ast_typed/ast_typed.ml +++ b/src/stages/4-ast_typed/ast_typed.ml @@ -2,6 +2,7 @@ module Types = Types module Environment = Environment module PP = PP module PP_generic = PP_generic +module Compare_generic = Compare_generic module Combinators = struct include Combinators end diff --git a/src/stages/4-ast_typed/types_utils.ml b/src/stages/4-ast_typed/types_utils.ml index 337e76ba0..8b6138f56 100644 --- a/src/stages/4-ast_typed/types_utils.ml +++ b/src/stages/4-ast_typed/types_utils.ml @@ -127,4 +127,3 @@ let fold_map__poly_set : type a state new_a . new_a extra_info__comparable -> (s ok (state , PolySet.add new_elt s) in let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in ok (state , m) - From 2d43f678931a7199ef368441ab940f587debe89d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Suzanne=20Dup=C3=A9ron?= Date: Sun, 31 May 2020 17:25:40 +0000 Subject: [PATCH 18/32] Revert "Merge branch 'ast/tuple_destruct' into 'dev'" This reverts merge request !650 --- src/passes/3-self_ast_imperative/helpers.ml | 15 --------------- .../imperative_to_sugar.ml | 18 +++--------------- src/passes/5-self_ast_sugar/helpers.ml | 15 --------------- src/passes/6-sugar_to_core/sugar_to_core.ml | 17 ----------------- src/stages/1-ast_imperative/PP.ml | 5 ----- src/stages/1-ast_imperative/combinators.ml | 1 - src/stages/1-ast_imperative/combinators.mli | 1 - src/stages/1-ast_imperative/types.ml | 2 -- src/stages/2-ast_sugar/PP.ml | 5 ----- src/stages/2-ast_sugar/combinators.ml | 1 - src/stages/2-ast_sugar/combinators.mli | 1 - src/stages/2-ast_sugar/types.ml | 2 -- 12 files changed, 3 insertions(+), 80 deletions(-) diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index 79e3b91c5..e08e1ef53 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -82,11 +82,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' tuple in ok res ) - | E_tuple_destruct {tuple; next} -> ( - let%bind res = self init' tuple in - let%bind res = self res next in - ok res - ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( let%bind res = self init' rhs in let%bind res = self res let_result in @@ -210,11 +205,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) - | E_tuple_destruct {tuple;fields;field_types;next} -> ( - let%bind tuple = self tuple in - let%bind next = self next in - return @@ E_tuple_destruct {tuple;fields;field_types;next} - ) | E_constructor c -> ( let%bind e' = self c.element in return @@ E_constructor {c with element = e'} @@ -394,11 +384,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) - | E_tuple_destruct {tuple;fields;field_types;next} -> ( - let%bind (res,tuple) = self init' tuple in - let%bind (res,next) = self res next in - ok (res, return @@ E_tuple_destruct {tuple;fields;field_types;next}) - ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index fda433669..224c2de10 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -57,10 +57,9 @@ let repair_mutable_variable_in_matching (match_body : O.expression) (element_nam | E_constant _ | E_skip | E_literal _ | E_variable _ - | E_application _ | E_lambda _| E_recursive _ | E_constructor _ - | E_record _| E_record_accessor _|E_record_update _ | E_ascription _ - | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ - | E_tuple_destruct _ + | E_application _ | E_lambda _| E_recursive _ + | E_constructor _ | E_record _| E_record_accessor _|E_record_update _ + | E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ | E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ -> ok (true, (decl_var, free_var),ass_exp) ) @@ -105,7 +104,6 @@ and repair_mutable_variable_in_loops (for_body : O.expression) (element_names : | E_application _ | E_lambda _| E_recursive _ | E_constructor _ | E_record _| E_record_accessor _|E_record_update _ | E_ascription _ | E_sequence _ | E_tuple _ | E_tuple_accessor _ | E_tuple_update _ - | E_tuple_destruct _ | E_map _ | E_big_map _ |E_list _ | E_set _ |E_look_up _ -> ok (true, (decl_var, free_var),ass_exp) ) @@ -337,11 +335,6 @@ and compile_expression' : I.expression -> (O.expression option -> O.expression) let%bind tuple = compile_expression tuple in let%bind update = compile_expression update in return @@ O.e_tuple_update ~loc tuple path update - | I.E_tuple_destruct {tuple; fields; field_types; next} -> - let%bind tuple = compile_expression tuple in - let%bind next = compile_expression next in - let%bind field_types = bind_map_option (bind_map_list compile_type_expression) field_types in - return @@ O.e_tuple_destruct ~loc tuple fields field_types next | I.E_assign {variable; access_path; expression} -> let accessor ?loc s a = match a with @@ -731,11 +724,6 @@ let rec uncompile_expression' : O.expression -> I.expression result = let%bind tuple = uncompile_expression' tuple in let%bind update = uncompile_expression' update in return @@ I.E_tuple_update {tuple;path;update} - | O.E_tuple_destruct {tuple; fields; field_types; next} -> - let%bind tuple = uncompile_expression' tuple in - let%bind next = uncompile_expression' next in - let%bind field_types = bind_map_option (bind_map_list uncompile_type_expression) field_types in - return @@ I.E_tuple_destruct {tuple; fields; field_types; next} | O.E_map map -> let%bind map = bind_map_list ( bind_map_pair uncompile_expression' diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 95d35d356..953a8910f 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -99,11 +99,6 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' tuple in ok res ) - | E_tuple_destruct {tuple; next} -> ( - let%bind res = self init' tuple in - let%bind res = self res next in - ok res - ) and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> @@ -230,11 +225,6 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind tuple = self tuple in return @@ E_tuple_accessor {tuple;path} ) - | E_tuple_destruct {tuple;fields;field_types;next} -> ( - let%bind tuple = self tuple in - let%bind next = self next in - return @@ E_tuple_destruct {tuple;fields;field_types;next} - ) | E_literal _ | E_variable _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> @@ -363,11 +353,6 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, tuple) = self init' tuple in ok (res, return @@ E_tuple_accessor {tuple; path}) ) - | E_tuple_destruct {tuple;fields;field_types;next} -> ( - let%bind (res,tuple) = self init' tuple in - let%bind (res,next) = self res next in - ok (res, return @@ E_tuple_destruct {tuple;fields;field_types;next}) - ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 05d2600da..165ff5577 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -193,23 +193,6 @@ let rec compile_expression : I.expression -> O.expression result = let path = O.Label (string_of_int path) in let%bind update = compile_expression update in return @@ O.E_record_update {record;path;update} - | I.E_tuple_destruct {tuple; fields; field_types; next} -> - let combine fields field_types = - match field_types with - Some ft -> List.combine fields @@ List.map (fun x -> Some x) ft - | None -> List.map (fun x -> (x, None)) fields - in - let%bind record = compile_expression tuple in - let%bind next = compile_expression next in - let%bind field_types = bind_map_option (bind_map_list idle_type_expression) field_types in - let aux ((index,e) : int * _ ) (field: O.expression_variable * O.type_expression option) = - let f = fun expr -> O.e_let_in field false (O.e_record_accessor record (string_of_int index)) expr in - (index+1, fun expr -> e (f expr)) - in - let (_,header) = List.fold_left aux (0, fun e -> e) @@ - combine fields field_types - in - ok @@ header next and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 081e5743a..6a2c835db 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -136,11 +136,6 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update - | E_tuple_destruct {tuple; fields; next; _} -> - fprintf ppf "{ let (%a) = %a in %a" - (list_sep_d expression_variable) fields - expression tuple - expression next | E_assign {variable; access_path; expression=e} -> fprintf ppf "%a%a := %a" expression_variable variable diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 586c36c07..4a4e88ed3 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -140,7 +140,6 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path : expression = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update : expression = make_e ?loc @@ E_tuple_update {tuple; path; update} -let e_tuple_destruct ?loc tuple fields field_types next = make_e ?loc @@ E_tuple_destruct {tuple; fields; field_types; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 68272942c..46e02fa9e 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -105,7 +105,6 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression -val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 19ab16d58..4651c1f9f 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -77,7 +77,6 @@ and expression_content = | E_tuple of expression list | E_tuple_accessor of tuple_accessor | E_tuple_update of tuple_update - | E_tuple_destruct of tuple_destruct (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -145,7 +144,6 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} -and tuple_destruct = {tuple: expression; fields : expression_variable list; field_types : type_expression list option; next : expression} and assign = { variable : expression_variable; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 31b991f07..3f348c52c 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -129,11 +129,6 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> fprintf ppf "{ %a with %d = %a }" expression tuple path expression update - | E_tuple_destruct {tuple; fields; next; _} -> - fprintf ppf "{ let (%a) = %a in %a" - (list_sep_d expression_variable) fields - expression tuple - expression next and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index dcf8ed421..8c8890748 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -129,7 +129,6 @@ let e_annotation ?loc anno_expr ty = make_e ?loc @@ E_ascription {anno_expr; typ let e_tuple ?loc lst : expression = make_e ?loc @@ E_tuple lst let e_tuple_accessor ?loc tuple path = make_e ?loc @@ E_tuple_accessor {tuple; path} let e_tuple_update ?loc tuple path update = make_e ?loc @@ E_tuple_update {tuple; path; update} -let e_tuple_destruct ?loc tuple fields field_types next = make_e ?loc @@ E_tuple_destruct {tuple; fields; field_types; next} let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let e_cond ?loc condition then_clause else_clause = make_e ?loc @@ E_cond {condition;then_clause;else_clause} diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index 94529b898..3faebef21 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -85,7 +85,6 @@ val e_annotation : ?loc:Location.t -> expression -> type_expression -> expressio val e_tuple : ?loc:Location.t -> expression list -> expression val e_tuple_accessor : ?loc:Location.t -> expression -> int -> expression val e_tuple_update : ?loc:Location.t -> expression -> int -> expression -> expression -val e_tuple_destruct : ?loc:Location.t -> expression -> expression_variable list -> type_expression list option -> expression -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 8c3422de6..88df116fb 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -77,7 +77,6 @@ and expression_content = | E_tuple of expression list | E_tuple_accessor of tuple_accessor | E_tuple_update of tuple_update - | E_tuple_destruct of tuple_destruct (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -139,7 +138,6 @@ and sequence = { and tuple_accessor = {tuple: expression; path: int} and tuple_update = {tuple: expression; path: int ; update: expression} -and tuple_destruct = {tuple: expression; fields : expression_variable list; field_types : type_expression list option; next : expression} and environment_element_definition = | ED_binder From 8d781eebca3bd17727c01a00e65f2da9ba901302 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Tue, 25 Feb 2020 00:04:52 -0800 Subject: [PATCH 19/32] Refactor id layer contract to use records instead of tuples --- src/test/contracts/id.mligo | 189 ++++++++++++++++++----------- src/test/id_tests.ml | 234 +++++++++++++++++++++--------------- 2 files changed, 256 insertions(+), 167 deletions(-) diff --git a/src/test/contracts/id.mligo b/src/test/contracts/id.mligo index e23f8d841..67233ce56 100644 --- a/src/test/contracts/id.mligo +++ b/src/test/contracts/id.mligo @@ -6,9 +6,21 @@ type id_details = { profile: bytes } -type buy = bytes * address option -type update_owner = id * address -type update_details = id * bytes option * address option +type buy = { + profile: bytes; + initial_controller: address option; +} + +type update_owner = { + id: id; + new_owner: address; +} + +type update_details = { + id: id; + new_profile: bytes option; + new_controller: address option; +} type action = | Buy of buy @@ -19,7 +31,14 @@ type action = (* The prices kept in storage can be changed by bakers, though they should only be adjusted down over time, not up. *) -type storage = (id, id_details) big_map * int * (tez * tez) +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage = { + identities: (id, id_details) big_map; + next_id: int; + name_price: tez; + skip_price: tez; +} type return = operation list * storage @@ -38,13 +57,17 @@ a lot that could be eaten up. Should probably do some napkin calculations for how expensive skipping needs to be to deter people from doing it just to chew up address space. *) -let buy (parameter, storage: (bytes * address option) * storage) = - let void : unit = - if Tezos.amount <> storage.2.0 - then (failwith "Incorrect amount paid.": unit) in - let profile, initial_controller = parameter in - let identities, new_id, prices = storage in - let controller : address = +let buy (parameter, storage: buy * storage) = + let void: unit = + if amount = storage.name_price + then () + else (failwith "Incorrect amount paid.": unit) + in + let profile = parameter.profile in + let initial_controller = parameter.initial_controller in + let identities = storage.identities in + let new_id = storage.next_id in + let controller: address = match initial_controller with | Some addr -> addr | None -> sender in @@ -54,74 +77,98 @@ let buy (parameter, storage: (bytes * address option) * storage) = profile = profile} in let updated_identities : (id, id_details) big_map = Big_map.update new_id (Some new_id_details) identities - in ([]: operation list), (updated_identities, new_id + 1, prices) + in + ([]: operation list), {identities = updated_identities; + next_id = new_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + } -let update_owner (parameter, storage : (id * address) * storage) = - if amount <> 0tez - then (failwith "Updating owner doesn't cost anything.": return) +let update_owner (parameter, storage: update_owner * storage) = + if (amount <> 0mutez) + then (failwith "Updating owner doesn't cost anything.": (operation list) * storage) else - let id, new_owner = parameter in - let identities, last_id, prices = storage in - let current_id_details : id_details = - match Big_map.find_opt id identities with - | Some id_details -> id_details - | None -> (failwith "This ID does not exist." : id_details) in - let is_allowed : bool = - if Tezos.sender = current_id_details.owner - then true - else (failwith "You are not the owner of this ID." : bool) in - let updated_id_details : id_details = { + let id = parameter.id in + let new_owner = parameter.new_owner in + let identities = storage.identities in + let current_id_details: id_details = + match Big_map.find_opt id identities with + | Some id_details -> id_details + | None -> (failwith "This ID does not exist.": id_details) + in + let is_allowed: bool = + if sender = current_id_details.owner + then true + else (failwith "You are not the owner of this ID.": bool) + in + let updated_id_details: id_details = { owner = new_owner; controller = current_id_details.controller; - profile = current_id_details.profile} in - let updated_identities = - Big_map.update id (Some updated_id_details) identities - in ([]: operation list), (updated_identities, last_id, prices) + profile = current_id_details.profile; + } + in + let updated_identities = Big_map.update id (Some updated_id_details) identities in + ([]: operation list), {identities = updated_identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + } -let update_details (parameter, storage: (id * bytes option * address option) * storage) = - if Tezos.amount <> 0tez - then - (failwith "Updating details doesn't cost anything." : return) +let update_details (parameter, storage: update_details * storage) = + if (amount <> 0mutez) + then (failwith "Updating details doesn't cost anything.": (operation list) * storage) else - let id, new_profile, new_controller = parameter in - let identities, last_id, prices = storage in - let current_id_details: id_details = - match Big_map.find_opt id identities with - | Some id_details -> id_details - | None -> (failwith "This ID does not exist.": id_details) in - let is_allowed : bool = - if Tezos.sender = current_id_details.controller - || Tezos.sender = current_id_details.owner - then true - else - (failwith ("You are not the owner or controller of this ID.") - : bool) in - let owner : address = current_id_details.owner in - let profile : bytes = - match new_profile with - | None -> (* Default *) current_id_details.profile - | Some new_profile -> new_profile in - let controller : address = - match new_controller with - | None -> (* Default *) current_id_details.controller - | Some new_controller -> new_controller in - let updated_id_details: id_details = { - owner = owner; - controller = controller; - profile = profile} in + let id = parameter.id in + let new_profile = parameter.new_profile in + let new_controller = parameter.new_controller in + let identities = storage.identities in + let current_id_details: id_details = + match Big_map.find_opt id identities with + | Some id_details -> id_details + | None -> (failwith "This ID does not exist.": id_details) + in + let is_allowed: bool = + if (sender = current_id_details.controller) || (sender = current_id_details.owner) + then true + else (failwith ("You are not the owner or controller of this ID."): bool) + in + let owner: address = current_id_details.owner in + let profile: bytes = + match new_profile with + | None -> (* Default *) current_id_details.profile + | Some new_profile -> new_profile + in + let controller: address = + match new_controller with + | None -> (* Default *) current_id_details.controller + | Some new_controller -> new_controller + in + let updated_id_details: id_details = { + owner = owner; + controller = controller; + profile = profile; + } + in let updated_identities: (id, id_details) big_map = - Big_map.update id (Some updated_id_details) identities - in ([]: operation list), (updated_identities, last_id, prices) + Big_map.update id (Some updated_id_details) identities in + ([]: operation list), {identities = updated_identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + } -(* Let someone skip the next identity so nobody has to take one that's -undesirable *) - -let skip (p, storage: unit * storage) = - let void : unit = - if Tezos.amount <> storage.2.1 - then (failwith "Incorrect amount paid." : unit) in - let identities, last_id, prices = storage in - ([]: operation list), (identities, last_id + 1, prices) +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +let skip (p,storage: unit * storage) = + let void: unit = + if amount = storage.skip_price + then () + else (failwith "Incorrect amount paid.": unit) + in + ([]: operation list), {identities = storage.identities; + next_id = storage.next_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + } let main (action, storage : action * storage) : return = match action with diff --git a/src/test/id_tests.ml b/src/test/id_tests.ml index a1fca2a62..d65f9675d 100644 --- a/src/test/id_tests.ml +++ b/src/test/id_tests.ml @@ -40,9 +40,10 @@ let buy_id () = ("controller", e_address owner_addr) ; ("profile", owner_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; - e_int 1; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let new_addr = first_owner in let options = Proto_alpha_utils.Memory_proto_alpha.make_options @@ -54,11 +55,15 @@ let buy_id () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let param = e_pair owner_website (e_some (e_address new_addr)) in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr))) ; + ] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let%bind () = expect_eq ~options (program, state) "buy" (e_pair param storage) @@ -73,9 +78,10 @@ let buy_id_sender_addr () = ("controller", e_address owner_addr) ; ("profile", owner_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; - e_int 1; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let new_addr = first_owner in let options = Proto_alpha_utils.Memory_proto_alpha.make_options @@ -87,11 +93,14 @@ let buy_id_sender_addr () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let param = e_pair owner_website (e_typed_none (t_address ())) in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_typed_none (t_address ())))] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let%bind () = expect_eq ~options (program, state) "buy" (e_pair param storage) @@ -107,18 +116,20 @@ let buy_id_wrong_amount () = ("controller", e_address owner_addr) ; ("profile", owner_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; - e_int 1; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let new_addr = first_owner in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:first_contract ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () in - let param = e_pair owner_website (e_some (e_address new_addr)) in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr)))] in let%bind () = expect_string_failwith ~options (program, state) "buy" - (e_pair param storage) + (e_pair param storage) "Incorrect amount paid." in ok () @@ -133,7 +144,7 @@ let update_details_owner () = let new_addr = first_owner in let options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender:first_contract - ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) () in let new_website = e_bytes_string "ligolang.org" in @@ -144,20 +155,24 @@ let update_details_owner () = let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ; ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2_diff)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let details = e_bytes_string "ligolang.org" in - let param = e_tuple [e_int 1 ; - e_some details ; - e_some (e_address new_addr)] in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address new_addr))] in let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) new_storage) @@ -185,20 +200,24 @@ let update_details_controller () = let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; ("controller", e_address owner_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2_diff)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let details = e_bytes_string "ligolang.org" in - let param = e_tuple [e_int 1 ; - e_some details ; - e_some (e_address owner_addr)] in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) new_storage) @@ -224,15 +243,17 @@ let update_details_nonexistent () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let details = e_bytes_string "ligolang.org" in - let param = e_tuple [e_int 2 ; - e_some details ; - e_some (e_address owner_addr)] in + let param = e_record_ez [("id", e_int 2) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in let%bind () = expect_string_failwith ~options (program, state) "update_details" (e_pair param storage) "This ID does not exist." @@ -257,15 +278,17 @@ let update_details_wrong_addr () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let details = e_bytes_string "ligolang.org" in - let param = e_tuple [e_int 0 ; - e_some details ; - e_some (e_address owner_addr)] in + let param = e_record_ez [("id", e_int 0) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in let%bind () = expect_string_failwith ~options (program, state) "update_details" (e_pair param storage) "You are not the owner or controller of this ID." @@ -291,14 +314,16 @@ let update_details_unchanged () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let param = e_tuple [e_int 1 ; - e_typed_none (t_bytes ()) ; - e_typed_none (t_address ())] in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_typed_none (t_bytes ())) ; + ("new_controller", e_typed_none (t_address ()))] in let%bind () = expect_eq ~options (program, state) "update_details" (e_pair param storage) (e_pair (e_list []) storage) @@ -326,17 +351,22 @@ let update_owner () = let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2_diff)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let param = e_pair (e_int 1) (e_address owner_addr) in + let param = e_record_ez [("id", e_int 1) ; + ("new_owner", e_address owner_addr)] in let%bind () = expect_eq ~options (program, state) "update_owner" (e_pair param storage) (e_pair (e_list []) new_storage) @@ -362,12 +392,15 @@ let update_owner_nonexistent () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let param = e_pair (e_int 2) (e_address new_addr) in + let param = e_record_ez [("id", e_int 2); + ("new_owner", e_address new_addr)] in let%bind () = expect_string_failwith ~options (program, state) "update_owner" (e_pair param storage) "This ID does not exist." @@ -393,12 +426,15 @@ let update_owner_wrong_addr () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let param = e_pair (e_int 0) (e_address new_addr) in + let param = e_record_ez [("id", e_int 0); + ("new_owner", e_address new_addr)] in let%bind () = expect_string_failwith ~options (program, state) "update_owner" (e_pair param storage) "You are not the owner of this ID." @@ -422,15 +458,19 @@ let skip () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in - let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 3; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 3) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let%bind () = expect_eq ~options (program, state) "skip" (e_pair (e_unit ()) storage) @@ -456,10 +496,12 @@ let skip_wrong_amount () = ("controller", e_address new_addr) ; ("profile", new_website)] in - let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; - (e_int 1, id_details_2)]) ; - e_int 2; - e_tuple [e_mutez 1000000 ; e_mutez 1000000]] + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] in let%bind () = expect_string_failwith ~options (program, state) "skip" (e_pair (e_unit ()) storage) From 4e984850c1f0176c2efb17c519ec30daef3f728d Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Thu, 27 Feb 2020 07:42:58 -0800 Subject: [PATCH 20/32] Add syntactically passing PascaLIGO ID contract that does not typecheck --- src/test/contracts/id.ligo | 178 +++++++++++++ src/test/id_tests_p.ml | 527 +++++++++++++++++++++++++++++++++++++ src/test/test.ml | 1 + 3 files changed, 706 insertions(+) create mode 100644 src/test/contracts/id.ligo create mode 100644 src/test/id_tests_p.ml diff --git a/src/test/contracts/id.ligo b/src/test/contracts/id.ligo new file mode 100644 index 000000000..ec4d3c1ca --- /dev/null +++ b/src/test/contracts/id.ligo @@ -0,0 +1,178 @@ +type id is int + +type id_details is + record [ + owner: address; + controller: address; + profile: bytes; + ] + +type buy is + record [ + profile: bytes; + initial_controller: option(address); + ] + +type update_owner is + record [ + id: id; + new_owner: address; + ] + +type update_details is + record [ + id: id; + new_profile: option(bytes); + new_controller: option(address); + ] + +type action is + | Buy of buy + | Update_owner of update_owner + | Update_details of update_details + | Skip of unit + +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage is + record [ + identities: big_map (id, id_details); + next_id: int; + name_price: tez; + skip_price: tez; + ] + +(** Preliminary thoughts on ids: + +I very much like the simplicity of http://gurno.com/adam/mne/. +5 three letter words means you have a 15 character identity, not actually more +annoying than an IP address and a lot more memorable than the raw digits. This +can be stored as a single integer which is then translated into the corresponding +series of 5 words. + +I in general like the idea of having a 'skip' mechanism, but it does need to cost +something so people don't eat up the address space. 256 ^ 5 means you have a lot +of address space, but if people troll by skipping a lot that could be eaten up. +Should probably do some napkin calculations for how expensive skipping needs to +be to deter people from doing it just to chew up address space. +*) + +function buy (const parameter : buy; const storage : storage) : list(operation) * storage is + begin + if amount = storage.name_price + then skip + else failwith("Incorrect amount paid."); + const profile : bytes = parameter.profile; + const initial_controller : option(address) = parameter.initial_controller; + var identities : big_map (id, id_details) := storage.identities; + const new_id : int = storage.next_id; + const controller : address = + case initial_controller of + Some(addr) -> addr + | None -> sender + end; + const new_id_details: id_details = + record [ + owner = sender ; + controller = controller ; + profile = profile ; + ]; + identities[new_id] := Some(new_id_details); + end with ((nil : list(operation)), record [ + identities = updated_identities; + next_id = new_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +function update_owner (const parameter : update_owner; const storage : storage) : + list(operation) * storage is + begin + if (amount =/= 0mutez) + then + begin + failwith("Updating owner doesn't cost anything."); + end + else skip; + const id : int = parameter[id]; + const new_owner : address = parameter[new_owner]; + var identities : big_map (id, id_details) := storage[identities]; + const id_details : id_details = + case identities[id] of + Some(id_details) -> id_details + | None -> (failwith("This ID does not exist."): id_details) + end; + var is_allowed : bool := false; + if sender = id_details[owner] + then is_allowed := true + else failwith("You are not the owner of this ID."); + id_details[owner] := new_owner; + identities[id] := Some(id_details); + end with ((nil: list(operation)), record [ + identities = updated_identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +function update_details (const parameter : update_details; const storage : storage ) : + list(operation) * storage is + begin + if (amount =/= 0mutez) + then failwith("Updating details doesn't cost anything.") + else skip; + const id : int = parameter[id]; + const new_profile : option(bytes) = parameter[new_profile]; + const new_controller : option(address) = parameter[new_controller]; + const identities : big_map (id, id_details) = storage[identities]; + const id_details: id_details = + case identities[id] of + Some(id_details) -> id_details + | None -> (failwith("This ID does not exist."): id_details) + end; + var is_allowed : bool := false; + if (sender = current_id_details[controller]) or (sender = current_id_details[owner]) + then is_allowed := true + else failwith("You are not the owner or controller of this ID."); + const owner: address = id_details[owner]; + const profile: bytes = + case new_profile of + None -> (* Default *) id_details[profile] + | Some(new_profile) -> new_profile + end; + const controller: address = + case new_controller of + None -> (* Default *) current_id_details[controller] + | Some(new_controller) -> new_controller + end; + id_details[owner] := owner; + id_details[controller] := controller; + id_details[profile] := profile; + identities[id] := Some(id_details); + end with ((nil: list(operation)), record [ + identities = identities; + next_id = storage[next_id]; + name_price = storage[name_price]; + skip_price = storage[skip_price]; + ]) + +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +function skip_ (const p: unit; const storage: storage) : list(operation) * storage is + begin + if amount = storage[skip_price] + then skip + else failwith("Incorrect amount paid."); + end with ((nil: list(operation)), record [ + identities = storage[identities]; + next_id = storage[next_id] + 1; + name_price = storage[name_price]; + skip_price = storage[skip_price]; + ]) + +function main (const action : action; const storage : storage) : list(operation) * storage is + case action of + | Buy(b) -> buy (b, storage) + | Update_owner(uo) -> update_owner (uo, storage) + | Update_details(ud) -> update_details (ud, storage) + | Skip(s) -> skip_ (unit, storage) + end; diff --git a/src/test/id_tests_p.ml b/src/test/id_tests_p.ml new file mode 100644 index 000000000..ab98a8c95 --- /dev/null +++ b/src/test/id_tests_p.ml @@ -0,0 +1,527 @@ +open Trace +open Test_helpers +open Ast_simplified + + +let mtype_file f = + let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in + let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + ok (typed,state) + +let get_program = + let s = ref None in + fun () -> match !s with + | Some s -> ok s + | None -> ( + let%bind program = mtype_file "./contracts/id.ligo" in + s := Some program ; + ok program + ) + +let compile_main () = + let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/id.ligo" (Syntax_name "pascaligo") in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in + let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in + let%bind (_contract: Tezos_utils.Michelson.michelson) = + (* fails if the given entry point is not a valid contract *) + Ligo.Compile.Of_michelson.build_contract michelson_prg in + ok () + +let (first_owner , first_contract) = + let open Proto_alpha_utils.Memory_proto_alpha in + let id = List.nth dummy_environment.identities 0 in + let kt = id.implicit_contract in + Protocol.Alpha_context.Contract.to_b58check kt , kt + +let buy_id () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr))) ; + ] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "buy" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +let buy_id_sender_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_typed_none t_address))] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "buy" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails if we attempt to buy an ID for the wrong amount *) +let buy_id_wrong_amount () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr)))] in + let%bind () = expect_string_failwith ~options program "buy" + (e_pair param storage) + "Incorrect amount paid." + in ok () + +let update_details_owner () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address owner_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address new_addr))] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +let update_details_controller () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails when we attempt to update details of nonexistent ID *) +let update_details_nonexistent () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 2) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_string_failwith ~options program "update_details" + (e_pair param storage) + "This ID does not exist." + in ok () + +(* Test that contract fails when we attempt to update details from wrong addr *) +let update_details_wrong_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 0) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_string_failwith ~options program "update_details" + (e_pair param storage) + "You are not the owner or controller of this ID." + in ok () + +(* Test that giving none on both profile and controller address is a no-op *) +let update_details_unchanged () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_typed_none t_bytes) ; + ("new_controller", e_typed_none t_address)] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) storage) + in ok () + +let update_owner () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 1) ; + ("new_owner", e_address owner_addr)] in + let%bind () = expect_eq ~options program "update_owner" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails when we attempt to update owner of nonexistent ID *) +let update_owner_nonexistent () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 2); + ("new_owner", e_address new_addr)] in + let%bind () = expect_string_failwith ~options program "update_owner" + (e_pair param storage) + "This ID does not exist." + in ok () + +(* Test that contract fails when we attempt to update owner from non-owner addr *) +let update_owner_wrong_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 0); + ("new_owner", e_address new_addr)] in + let%bind () = expect_string_failwith ~options program "update_owner" + (e_pair param storage) + "You are not the owner of this ID." + in ok () + +let skip () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 3) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "skip" + (e_pair (e_unit ()) storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails if we try to skip without paying the right amount *) +let skip_wrong_amount () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_string_failwith ~options program "skip" + (e_pair (e_unit ()) storage) + "Incorrect amount paid." + in ok () + +let main = test_suite "ID Layer" [ + test "buy" buy_id ; + test "buy (sender addr)" buy_id_sender_addr ; + test "buy (wrong amount)" buy_id_wrong_amount ; + test "update_details (owner)" update_details_owner ; + test "update_details (controller)" update_details_controller ; + test "update_details_nonexistent" update_details_nonexistent ; + test "update_details_wrong_addr" update_details_wrong_addr ; + test "update_details_unchanged" update_details_unchanged ; + test "update_owner" update_owner ; + test "update_owner_nonexistent" update_owner_nonexistent ; + test "update_owner_wrong_addr" update_owner_wrong_addr ; + test "skip" skip ; + test "skip (wrong amount)" skip_wrong_amount ; +] diff --git a/src/test/test.ml b/src/test/test.ml index 01d8a78f6..04eb54428 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -11,6 +11,7 @@ let () = Coase_tests.main ; Vote_tests.main ; Id_tests.main ; + Id_tests_p.main ; Multisig_tests.main ; Multisig_v2_tests.main ; Replaceable_id_tests.main ; From 4d16b006c6c99f1fa499f62dd46164aba03e894a Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Thu, 27 Feb 2020 23:22:55 -0800 Subject: [PATCH 21/32] Fix PascaLIGO ID contract to pass tests --- src/test/contracts/id.ligo | 66 +++++++++++++++++++------------------- src/test/id_tests_p.ml | 6 ++-- 2 files changed, 36 insertions(+), 36 deletions(-) diff --git a/src/test/contracts/id.ligo b/src/test/contracts/id.ligo index ec4d3c1ca..7f6418127 100644 --- a/src/test/contracts/id.ligo +++ b/src/test/contracts/id.ligo @@ -77,9 +77,9 @@ function buy (const parameter : buy; const storage : storage) : list(operation) controller = controller ; profile = profile ; ]; - identities[new_id] := Some(new_id_details); + identities[new_id] := new_id_details; end with ((nil : list(operation)), record [ - identities = updated_identities; + identities = identities; next_id = new_id + 1; name_price = storage.name_price; skip_price = storage.skip_price; @@ -94,22 +94,22 @@ function update_owner (const parameter : update_owner; const storage : storage) failwith("Updating owner doesn't cost anything."); end else skip; - const id : int = parameter[id]; - const new_owner : address = parameter[new_owner]; - var identities : big_map (id, id_details) := storage[identities]; + const id : int = parameter.id; + const new_owner : address = parameter.new_owner; + var identities : big_map (id, id_details) := storage.identities; const id_details : id_details = case identities[id] of Some(id_details) -> id_details | None -> (failwith("This ID does not exist."): id_details) end; - var is_allowed : bool := false; - if sender = id_details[owner] - then is_allowed := true + var is_allowed : bool := False; + if sender = id_details.owner + then is_allowed := True else failwith("You are not the owner of this ID."); - id_details[owner] := new_owner; - identities[id] := Some(id_details); + id_details.owner := new_owner; + identities[id] := id_details; end with ((nil: list(operation)), record [ - identities = updated_identities; + identities = identities; next_id = storage.next_id; name_price = storage.name_price; skip_price = storage.skip_price; @@ -121,52 +121,52 @@ function update_details (const parameter : update_details; const storage : stora if (amount =/= 0mutez) then failwith("Updating details doesn't cost anything.") else skip; - const id : int = parameter[id]; - const new_profile : option(bytes) = parameter[new_profile]; - const new_controller : option(address) = parameter[new_controller]; - const identities : big_map (id, id_details) = storage[identities]; + const id : int = parameter.id; + const new_profile : option(bytes) = parameter.new_profile; + const new_controller : option(address) = parameter.new_controller; + const identities : big_map (id, id_details) = storage.identities; const id_details: id_details = case identities[id] of Some(id_details) -> id_details | None -> (failwith("This ID does not exist."): id_details) end; - var is_allowed : bool := false; - if (sender = current_id_details[controller]) or (sender = current_id_details[owner]) - then is_allowed := true + var is_allowed : bool := False; + if (sender = id_details.controller) or (sender = id_details.owner) + then is_allowed := True else failwith("You are not the owner or controller of this ID."); - const owner: address = id_details[owner]; + const owner: address = id_details.owner; const profile: bytes = case new_profile of - None -> (* Default *) id_details[profile] + None -> (* Default *) id_details.profile | Some(new_profile) -> new_profile end; const controller: address = case new_controller of - None -> (* Default *) current_id_details[controller] + None -> (* Default *) id_details.controller | Some(new_controller) -> new_controller end; - id_details[owner] := owner; - id_details[controller] := controller; - id_details[profile] := profile; - identities[id] := Some(id_details); + id_details.owner := owner; + id_details.controller := controller; + id_details.profile := profile; + identities[id] := id_details; end with ((nil: list(operation)), record [ identities = identities; - next_id = storage[next_id]; - name_price = storage[name_price]; - skip_price = storage[skip_price]; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; ]) (* Let someone skip the next identity so nobody has to take one that's undesirable *) function skip_ (const p: unit; const storage: storage) : list(operation) * storage is begin - if amount = storage[skip_price] + if amount = storage.skip_price then skip else failwith("Incorrect amount paid."); end with ((nil: list(operation)), record [ - identities = storage[identities]; - next_id = storage[next_id] + 1; - name_price = storage[name_price]; - skip_price = storage[skip_price]; + identities = storage.identities; + next_id = storage.next_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; ]) function main (const action : action; const storage : storage) : list(operation) * storage is diff --git a/src/test/id_tests_p.ml b/src/test/id_tests_p.ml index ab98a8c95..81f08c556 100644 --- a/src/test/id_tests_p.ml +++ b/src/test/id_tests_p.ml @@ -474,7 +474,7 @@ let skip () = ("name_price", e_mutez 1000000) ; ("skip_price", e_mutez 1000000) ; ] in - let%bind () = expect_eq ~options program "skip" + let%bind () = expect_eq ~options program "skip_" (e_pair (e_unit ()) storage) (e_pair (e_list []) new_storage) in ok () @@ -505,12 +505,12 @@ let skip_wrong_amount () = ("name_price", e_mutez 1000000) ; ("skip_price", e_mutez 1000000) ; ] in - let%bind () = expect_string_failwith ~options program "skip" + let%bind () = expect_string_failwith ~options program "skip_" (e_pair (e_unit ()) storage) "Incorrect amount paid." in ok () -let main = test_suite "ID Layer" [ +let main = test_suite "ID Layer (PascaLIGO)" [ test "buy" buy_id ; test "buy (sender addr)" buy_id_sender_addr ; test "buy (wrong amount)" buy_id_wrong_amount ; From 37a3fde6fd41447730003f46b031b0b2d01ad584 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Sat, 29 Feb 2020 00:12:24 -0800 Subject: [PATCH 22/32] Add ReasonLIGO version of ID layer contract Change CameLIGO version tests to say they're for CameLIGO in test suite --- src/test/contracts/id.religo | 184 ++++++++++++ src/test/id_tests.ml | 2 +- src/test/id_tests_r.ml | 527 +++++++++++++++++++++++++++++++++++ src/test/test.ml | 1 + 4 files changed, 713 insertions(+), 1 deletion(-) create mode 100644 src/test/contracts/id.religo create mode 100644 src/test/id_tests_r.ml diff --git a/src/test/contracts/id.religo b/src/test/contracts/id.religo new file mode 100644 index 000000000..6fe854e6c --- /dev/null +++ b/src/test/contracts/id.religo @@ -0,0 +1,184 @@ +type id = int + +type id_details = { + owner: address, + controller: address, + profile: bytes, +} + +type buy = { + profile: bytes, + initial_controller: option(address), +} + +type update_owner = { + id: id, + new_owner: address, +} + +type update_details = { + id: id, + new_profile: option(bytes), + new_controller: option(address), +} + +type action = +| Buy(buy) +| Update_owner(update_owner) +| Update_details(update_details) +| Skip(unit) + +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage = { + identities: big_map (id, id_details), + next_id: int, + name_price: tez, + skip_price: tez, +} + +(** Preliminary thoughts on ids: + +I very much like the simplicity of http://gurno.com/adam/mne/. +5 three letter words means you have a 15 character identity, not actually more +annoying than an IP address and a lot more memorable than the raw digits. This +can be stored as a single integer which is then translated into the corresponding +series of 5 words. + +I in general like the idea of having a 'skip' mechanism, but it does need to cost +something so people don't eat up the address space. 256 ^ 5 means you have a lot +of address space, but if people troll by skipping a lot that could be eaten up. +Should probably do some napkin calculations for how expensive skipping needs to +be to deter people from doing it just to chew up address space. +*) + +let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => { + let void: unit = + if (amount == storage.name_price) { (); } + else { failwith("Incorrect amount paid."); }; + let profile = parameter.profile; + let initial_controller = parameter.initial_controller; + let identities = storage.identities; + let new_id = storage.next_id; + let controller: address = + switch (initial_controller) { + | Some(addr) => addr + | None => sender + }; + let new_id_details: id_details = { + owner : sender, + controller : controller, + profile : profile, + }; + let updated_identities: big_map (id, id_details) = + Big_map.update(new_id, Some(new_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : new_id + 1, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let update_owner = ((parameter, storage): (update_owner, storage)) : (list(operation), storage) => { + let void: unit = + if (amount != 0mutez) { + failwith("Updating owner doesn't cost anything."); + } + else { (); }; + let id : int = parameter.id; + let new_owner = parameter.new_owner; + let identities = storage.identities; + let current_id_details: id_details = + switch (Big_map.find_opt(id, identities)) { + | Some(id_details) => id_details + | None => (failwith("This ID does not exist."): id_details) + }; + let is_allowed: bool = + if (sender == current_id_details.owner) { true; } + else { (failwith("You are not the owner of this ID."): bool); }; + let updated_id_details: id_details = { + owner : new_owner, + controller : current_id_details.controller, + profile : current_id_details.profile, + }; + let updated_identities = Big_map.update(id, (Some updated_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : storage.next_id, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let update_details = ((parameter, storage): (update_details, storage)) : + (list(operation), storage) => { + let void : unit = + if (amount != 0mutez) { + failwith("Updating details doesn't cost anything."); + } + else { (); }; + let id = parameter.id; + let new_profile = parameter.new_profile; + let new_controller = parameter.new_controller; + let identities = storage.identities; + let current_id_details: id_details = + switch (Big_map.find_opt(id, identities)) { + | Some(id_details) => id_details + | None => (failwith("This ID does not exist."): id_details) + }; + let is_allowed: bool = + if ((sender != current_id_details.controller) && + (sender != current_id_details.owner)) { + (failwith ("You are not the owner or controller of this ID."): bool) + } + else { true; }; + let owner: address = current_id_details.owner; + let profile: bytes = + switch (new_profile) { + | None => (* Default *) current_id_details.profile + | Some(new_profile) => new_profile + }; + let controller: address = + switch (new_controller) { + | None => (* Default *) current_id_details.controller + | Some new_controller => new_controller + }; + let updated_id_details: id_details = { + owner : owner, + controller : controller, + profile : profile, + }; + let updated_identities: big_map (id, id_details) = + Big_map.update(id, (Some updated_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : storage.next_id, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +let skip = ((p,storage): (unit, storage)) => { + let void : unit = + if (amount != storage.skip_price) { + failwith("Incorrect amount paid."); + } + else { (); }; + (([]: list(operation)), { + identities : storage.identities, + next_id : storage.next_id + 1, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let main = ((action, storage): (action, storage)) : (list(operation), storage) => { + switch (action) { + | Buy(b) => buy((b, storage)) + | Update_owner(uo) => update_owner((uo, storage)) + | Update_details ud => update_details((ud, storage)) + | Skip s => skip(((), storage)) + }; +}; diff --git a/src/test/id_tests.ml b/src/test/id_tests.ml index d65f9675d..9c86aecc5 100644 --- a/src/test/id_tests.ml +++ b/src/test/id_tests.ml @@ -508,7 +508,7 @@ let skip_wrong_amount () = "Incorrect amount paid." in ok () -let main = test_suite "ID Layer" [ +let main = test_suite "ID Layer (CameLIGO)" [ test "buy" buy_id ; test "buy (sender addr)" buy_id_sender_addr ; test "buy (wrong amount)" buy_id_wrong_amount ; diff --git a/src/test/id_tests_r.ml b/src/test/id_tests_r.ml new file mode 100644 index 000000000..d795134e1 --- /dev/null +++ b/src/test/id_tests_r.ml @@ -0,0 +1,527 @@ +open Trace +open Test_helpers +open Ast_simplified + + +let mtype_file f = + let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "reasonligo") in + let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in + ok (typed,state) + +let get_program = + let s = ref None in + fun () -> match !s with + | Some s -> ok s + | None -> ( + let%bind program = mtype_file "./contracts/id.religo" in + s := Some program ; + ok program + ) + +let compile_main () = + let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/id.religo" (Syntax_name "reasonligo") in + let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in + let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in + let%bind (_contract: Tezos_utils.Michelson.michelson) = + (* fails if the given entry point is not a valid contract *) + Ligo.Compile.Of_michelson.build_contract michelson_prg in + ok () + +let (first_owner , first_contract) = + let open Proto_alpha_utils.Memory_proto_alpha in + let id = List.nth dummy_environment.identities 0 in + let kt = id.implicit_contract in + Protocol.Alpha_context.Contract.to_b58check kt , kt + +let buy_id () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr))) ; + ] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "buy" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +let buy_id_sender_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_typed_none t_address))] in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "buy" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails if we attempt to buy an ID for the wrong amount *) +let buy_id_wrong_amount () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ; + ("next_id", e_int 1) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () + in + let param = e_record_ez [("profile", owner_website) ; + ("initial_controller", (e_some (e_address new_addr)))] in + let%bind () = expect_string_failwith ~options program "buy" + (e_pair param storage) + "Incorrect amount paid." + in ok () + +let update_details_owner () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address owner_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address new_addr))] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +let update_details_controller () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails when we attempt to update details of nonexistent ID *) +let update_details_nonexistent () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 2) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_string_failwith ~options program "update_details" + (e_pair param storage) + "This ID does not exist." + in ok () + +(* Test that contract fails when we attempt to update details from wrong addr *) +let update_details_wrong_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let details = e_bytes_string "ligolang.org" in + let param = e_record_ez [("id", e_int 0) ; + ("new_profile", e_some details) ; + ("new_controller", e_some (e_address owner_addr))] in + let%bind () = expect_string_failwith ~options program "update_details" + (e_pair param storage) + "You are not the owner or controller of this ID." + in ok () + +(* Test that giving none on both profile and controller address is a no-op *) +let update_details_unchanged () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 1) ; + ("new_profile", e_typed_none t_bytes) ; + ("new_controller", e_typed_none t_address)] in + let%bind () = expect_eq ~options program "update_details" + (e_pair param storage) + (e_pair (e_list []) storage) + in ok () + +let update_owner () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2_diff)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 1) ; + ("new_owner", e_address owner_addr)] in + let%bind () = expect_eq ~options program "update_owner" + (e_pair param storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails when we attempt to update owner of nonexistent ID *) +let update_owner_nonexistent () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 2); + ("new_owner", e_address new_addr)] in + let%bind () = expect_string_failwith ~options program "update_owner" + (e_pair param storage) + "This ID does not exist." + in ok () + +(* Test that contract fails when we attempt to update owner from non-owner addr *) +let update_owner_wrong_addr () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) + () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let param = e_record_ez [("id", e_int 0); + ("new_owner", e_address new_addr)] in + let%bind () = expect_string_failwith ~options program "update_owner" + (e_pair param storage) + "You are not the owner of this ID." + in ok () + +let skip () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let new_storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 3) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_eq ~options program "skip" + (e_pair (e_unit ()) storage) + (e_pair (e_list []) new_storage) + in ok () + +(* Test that contract fails if we try to skip without paying the right amount *) +let skip_wrong_amount () = + let%bind program, _ = get_program () in + let owner_addr = addr 5 in + let owner_website = e_bytes_string "ligolang.org" in + let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; + ("controller", e_address owner_addr) ; + ("profile", owner_website)] + in + let new_addr = first_owner in + let options = Proto_alpha_utils.Memory_proto_alpha.make_options + ~sender:first_contract + ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () + in + let new_website = e_bytes_string "ligolang.org" in + let id_details_2 = e_record_ez [("owner", e_address new_addr) ; + ("controller", e_address new_addr) ; + ("profile", new_website)] + in + let storage = e_record_ez [("identities", (e_big_map + [(e_int 0, id_details_1) ; + (e_int 1, id_details_2)])) ; + ("next_id", e_int 2) ; + ("name_price", e_mutez 1000000) ; + ("skip_price", e_mutez 1000000) ; ] + in + let%bind () = expect_string_failwith ~options program "skip" + (e_pair (e_unit ()) storage) + "Incorrect amount paid." + in ok () + +let main = test_suite "ID Layer (ReasonLIGO)" [ + test "buy" buy_id ; + test "buy (sender addr)" buy_id_sender_addr ; + test "buy (wrong amount)" buy_id_wrong_amount ; + test "update_details (owner)" update_details_owner ; + test "update_details (controller)" update_details_controller ; + test "update_details_nonexistent" update_details_nonexistent ; + test "update_details_wrong_addr" update_details_wrong_addr ; + test "update_details_unchanged" update_details_unchanged ; + test "update_owner" update_owner ; + test "update_owner_nonexistent" update_owner_nonexistent ; + test "update_owner_wrong_addr" update_owner_wrong_addr ; + test "skip" skip ; + test "skip (wrong amount)" skip_wrong_amount ; +] diff --git a/src/test/test.ml b/src/test/test.ml index 04eb54428..b6a9a9c41 100644 --- a/src/test/test.ml +++ b/src/test/test.ml @@ -12,6 +12,7 @@ let () = Vote_tests.main ; Id_tests.main ; Id_tests_p.main ; + Id_tests_r.main ; Multisig_tests.main ; Multisig_v2_tests.main ; Replaceable_id_tests.main ; From e42e79eff3acedcf8ad80ac4fe4425598fb0eb10 Mon Sep 17 00:00:00 2001 From: John David Pressman Date: Wed, 4 Mar 2020 03:32:58 -0800 Subject: [PATCH 23/32] Add ID contract examples to web ide without command defaults --- src/test/contracts/id.religo | 14 +- src/test/examples/cameligo/id.mligo | 195 +++++++++++++++++ src/test/examples/pascaligo/id.ligo | 197 +++++++++++++++++ src/test/examples/reasonligo/id.religo | 203 ++++++++++++++++++ src/test/id_tests_p.ml | 18 +- src/test/id_tests_r.ml | 18 +- .../packages/client/package-examples.js | 9 + 7 files changed, 627 insertions(+), 27 deletions(-) create mode 100644 src/test/examples/cameligo/id.mligo create mode 100644 src/test/examples/pascaligo/id.ligo create mode 100644 src/test/examples/reasonligo/id.religo diff --git a/src/test/contracts/id.religo b/src/test/contracts/id.religo index 6fe854e6c..d5814e211 100644 --- a/src/test/contracts/id.religo +++ b/src/test/contracts/id.religo @@ -28,8 +28,8 @@ type action = | Update_details(update_details) | Skip(unit) -(* The prices kept in storage can be changed by bakers, though they should only be - adjusted down over time, not up. *) +/* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. */ type storage = { identities: big_map (id, id_details), next_id: int, @@ -37,7 +37,7 @@ type storage = { skip_price: tez, } -(** Preliminary thoughts on ids: +/** Preliminary thoughts on ids: I very much like the simplicity of http://gurno.com/adam/mne/. 5 three letter words means you have a 15 character identity, not actually more @@ -50,7 +50,7 @@ something so people don't eat up the address space. 256 ^ 5 means you have a lot of address space, but if people troll by skipping a lot that could be eaten up. Should probably do some napkin calculations for how expensive skipping needs to be to deter people from doing it just to chew up address space. -*) +*/ let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => { let void: unit = @@ -136,12 +136,12 @@ let update_details = ((parameter, storage): (update_details, storage)) : let owner: address = current_id_details.owner; let profile: bytes = switch (new_profile) { - | None => (* Default *) current_id_details.profile + | None => /* Default */ current_id_details.profile | Some(new_profile) => new_profile }; let controller: address = switch (new_controller) { - | None => (* Default *) current_id_details.controller + | None => /* Default */ current_id_details.controller | Some new_controller => new_controller }; let updated_id_details: id_details = { @@ -159,7 +159,7 @@ let update_details = ((parameter, storage): (update_details, storage)) : }); }; -(* Let someone skip the next identity so nobody has to take one that's undesirable *) +/* Let someone skip the next identity so nobody has to take one that's undesirable */ let skip = ((p,storage): (unit, storage)) => { let void : unit = if (amount != storage.skip_price) { diff --git a/src/test/examples/cameligo/id.mligo b/src/test/examples/cameligo/id.mligo new file mode 100644 index 000000000..2019eb815 --- /dev/null +++ b/src/test/examples/cameligo/id.mligo @@ -0,0 +1,195 @@ +(*_* + name: ID Contract (CameLIGO) + language: cameligo + compile: + entrypoint: main + dryRun: + entrypoint: main + parameters: Increment 1 + storage: 0 + deploy: + entrypoint: main + storage: 0 + evaluateValue: + entrypoint: "" + evaluateFunction: + entrypoint: add + parameters: 5, 6 +*_*) + +type id = int + +type id_details = { + owner: address; + controller: address; + profile: bytes; +} + +type buy = { + profile: bytes; + initial_controller: address option; +} + +type update_owner = { + id: id; + new_owner: address; +} + +type update_details = { + id: id; + new_profile: bytes option; + new_controller: address option; +} + +type action = +| Buy of buy +| Update_owner of update_owner +| Update_details of update_details +| Skip of unit + +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage = { + identities: (id, id_details) big_map; + next_id: int; + name_price: tez; + skip_price: tez; +} + +(** Preliminary thoughts on ids: + +I very much like the simplicity of http://gurno.com/adam/mne/. +5 three letter words means you have a 15 character identity, not actually more +annoying than an IP address and a lot more memorable than the raw digits. This +can be stored as a single integer which is then translated into the corresponding +series of 5 words. + +I in general like the idea of having a 'skip' mechanism, but it does need to cost +something so people don't eat up the address space. 256 ^ 5 means you have a lot +of address space, but if people troll by skipping a lot that could be eaten up. +Should probably do some napkin calculations for how expensive skipping needs to +be to deter people from doing it just to chew up address space. +*) + +let buy (parameter, storage: buy * storage) = + let void: unit = + if amount = storage.name_price + then () + else (failwith "Incorrect amount paid.": unit) + in + let profile = parameter.profile in + let initial_controller = parameter.initial_controller in + let identities = storage.identities in + let new_id = storage.next_id in + let controller: address = + match initial_controller with + | Some addr -> addr + | None -> sender + in + let new_id_details: id_details = { + owner = sender ; + controller = controller ; + profile = profile ; + } + in + let updated_identities: (id, id_details) big_map = + Big_map.update new_id (Some new_id_details) identities + in + ([]: operation list), {identities = updated_identities; + next_id = new_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + } + +let update_owner (parameter, storage: update_owner * storage) = + if (amount <> 0mutez) + then (failwith "Updating owner doesn't cost anything.": (operation list) * storage) + else + let id = parameter.id in + let new_owner = parameter.new_owner in + let identities = storage.identities in + let current_id_details: id_details = + match Big_map.find_opt id identities with + | Some id_details -> id_details + | None -> (failwith "This ID does not exist.": id_details) + in + let is_allowed: bool = + if sender = current_id_details.owner + then true + else (failwith "You are not the owner of this ID.": bool) + in + let updated_id_details: id_details = { + owner = new_owner; + controller = current_id_details.controller; + profile = current_id_details.profile; + } + in + let updated_identities = Big_map.update id (Some updated_id_details) identities in + ([]: operation list), {identities = updated_identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + } + +let update_details (parameter, storage: update_details * storage) = + if (amount <> 0mutez) + then (failwith "Updating details doesn't cost anything.": (operation list) * storage) + else + let id = parameter.id in + let new_profile = parameter.new_profile in + let new_controller = parameter.new_controller in + let identities = storage.identities in + let current_id_details: id_details = + match Big_map.find_opt id identities with + | Some id_details -> id_details + | None -> (failwith "This ID does not exist.": id_details) + in + let is_allowed: bool = + if (sender = current_id_details.controller) || (sender = current_id_details.owner) + then true + else (failwith ("You are not the owner or controller of this ID."): bool) + in + let owner: address = current_id_details.owner in + let profile: bytes = + match new_profile with + | None -> (* Default *) current_id_details.profile + | Some new_profile -> new_profile + in + let controller: address = + match new_controller with + | None -> (* Default *) current_id_details.controller + | Some new_controller -> new_controller + in + let updated_id_details: id_details = { + owner = owner; + controller = controller; + profile = profile; + } + in + let updated_identities: (id, id_details) big_map = + Big_map.update id (Some updated_id_details) identities in + ([]: operation list), {identities = updated_identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + } + +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +let skip (p,storage: unit * storage) = + let void: unit = + if amount = storage.skip_price + then () + else (failwith "Incorrect amount paid.": unit) + in + ([]: operation list), {identities = storage.identities; + next_id = storage.next_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + } + +let main (action, storage: action * storage) : operation list * storage = + match action with + | Buy b -> buy (b, storage) + | Update_owner uo -> update_owner (uo, storage) + | Update_details ud -> update_details (ud, storage) + | Skip s -> skip ((), storage) diff --git a/src/test/examples/pascaligo/id.ligo b/src/test/examples/pascaligo/id.ligo new file mode 100644 index 000000000..ece089aa9 --- /dev/null +++ b/src/test/examples/pascaligo/id.ligo @@ -0,0 +1,197 @@ +(*_* + name: ID Contract (PascaLIGO) + language: pascaligo + compile: + entrypoint: main + dryRun: + entrypoint: main + parameters: Increment 1 + storage: 0 + deploy: + entrypoint: main + storage: 0 + evaluateValue: + entrypoint: "" + evaluateFunction: + entrypoint: add + parameters: 5, 6 +*_*) + +type id is int + +type id_details is + record [ + owner: address; + controller: address; + profile: bytes; + ] + +type buy is + record [ + profile: bytes; + initial_controller: option(address); + ] + +type update_owner is + record [ + id: id; + new_owner: address; + ] + +type update_details is + record [ + id: id; + new_profile: option(bytes); + new_controller: option(address); + ] + +type action is + | Buy of buy + | Update_owner of update_owner + | Update_details of update_details + | Skip of unit + +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage is + record [ + identities: big_map (id, id_details); + next_id: int; + name_price: tez; + skip_price: tez; + ] + +(** Preliminary thoughts on ids: + +I very much like the simplicity of http://gurno.com/adam/mne/. +5 three letter words means you have a 15 character identity, not actually more +annoying than an IP address and a lot more memorable than the raw digits. This +can be stored as a single integer which is then translated into the corresponding +series of 5 words. + +I in general like the idea of having a 'skip' mechanism, but it does need to cost +something so people don't eat up the address space. 256 ^ 5 means you have a lot +of address space, but if people troll by skipping a lot that could be eaten up. +Should probably do some napkin calculations for how expensive skipping needs to +be to deter people from doing it just to chew up address space. +*) + +function buy (const parameter : buy; const storage : storage) : list(operation) * storage is + begin + if amount = storage.name_price + then skip + else failwith("Incorrect amount paid."); + const profile : bytes = parameter.profile; + const initial_controller : option(address) = parameter.initial_controller; + var identities : big_map (id, id_details) := storage.identities; + const new_id : int = storage.next_id; + const controller : address = + case initial_controller of + Some(addr) -> addr + | None -> sender + end; + const new_id_details: id_details = + record [ + owner = sender ; + controller = controller ; + profile = profile ; + ]; + identities[new_id] := new_id_details; + end with ((nil : list(operation)), record [ + identities = identities; + next_id = new_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +function update_owner (const parameter : update_owner; const storage : storage) : + list(operation) * storage is + begin + if (amount =/= 0mutez) + then + begin + failwith("Updating owner doesn't cost anything."); + end + else skip; + const id : int = parameter.id; + const new_owner : address = parameter.new_owner; + var identities : big_map (id, id_details) := storage.identities; + const id_details : id_details = + case identities[id] of + Some(id_details) -> id_details + | None -> (failwith("This ID does not exist."): id_details) + end; + var is_allowed : bool := False; + if sender = id_details.owner + then is_allowed := True + else failwith("You are not the owner of this ID."); + id_details.owner := new_owner; + identities[id] := id_details; + end with ((nil: list(operation)), record [ + identities = identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +function update_details (const parameter : update_details; const storage : storage ) : + list(operation) * storage is + begin + if (amount =/= 0mutez) + then failwith("Updating details doesn't cost anything.") + else skip; + const id : int = parameter.id; + const new_profile : option(bytes) = parameter.new_profile; + const new_controller : option(address) = parameter.new_controller; + const identities : big_map (id, id_details) = storage.identities; + const id_details: id_details = + case identities[id] of + Some(id_details) -> id_details + | None -> (failwith("This ID does not exist."): id_details) + end; + var is_allowed : bool := False; + if (sender = id_details.controller) or (sender = id_details.owner) + then is_allowed := True + else failwith("You are not the owner or controller of this ID."); + const owner: address = id_details.owner; + const profile: bytes = + case new_profile of + None -> (* Default *) id_details.profile + | Some(new_profile) -> new_profile + end; + const controller: address = + case new_controller of + None -> (* Default *) id_details.controller + | Some(new_controller) -> new_controller + end; + id_details.owner := owner; + id_details.controller := controller; + id_details.profile := profile; + identities[id] := id_details; + end with ((nil: list(operation)), record [ + identities = identities; + next_id = storage.next_id; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +function skip_ (const p: unit; const storage: storage) : list(operation) * storage is + begin + if amount = storage.skip_price + then skip + else failwith("Incorrect amount paid."); + end with ((nil: list(operation)), record [ + identities = storage.identities; + next_id = storage.next_id + 1; + name_price = storage.name_price; + skip_price = storage.skip_price; + ]) + +function main (const action : action; const storage : storage) : list(operation) * storage is + case action of + | Buy(b) -> buy (b, storage) + | Update_owner(uo) -> update_owner (uo, storage) + | Update_details(ud) -> update_details (ud, storage) + | Skip(s) -> skip_ (unit, storage) + end; diff --git a/src/test/examples/reasonligo/id.religo b/src/test/examples/reasonligo/id.religo new file mode 100644 index 000000000..3177c8fa5 --- /dev/null +++ b/src/test/examples/reasonligo/id.religo @@ -0,0 +1,203 @@ +(*_* + name: ID Contract (ReasonLIGO) + language: reasonligo + compile: + entrypoint: main + dryRun: + entrypoint: main + parameters: Increment 1 + storage: 0 + deploy: + entrypoint: main + storage: 0 + evaluateValue: + entrypoint: "" + evaluateFunction: + entrypoint: add + parameters: 5, 6 +*_*) + +type id = int + +type id_details = { + owner: address, + controller: address, + profile: bytes, +} + +type buy = { + profile: bytes, + initial_controller: option(address), +} + +type update_owner = { + id: id, + new_owner: address, +} + +type update_details = { + id: id, + new_profile: option(bytes), + new_controller: option(address), +} + +type action = +| Buy(buy) +| Update_owner(update_owner) +| Update_details(update_details) +| Skip(unit) + +(* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. *) +type storage = { + identities: big_map (id, id_details), + next_id: int, + name_price: tez, + skip_price: tez, +} + +(** Preliminary thoughts on ids: + +I very much like the simplicity of http://gurno.com/adam/mne/. +5 three letter words means you have a 15 character identity, not actually more +annoying than an IP address and a lot more memorable than the raw digits. This +can be stored as a single integer which is then translated into the corresponding +series of 5 words. + +I in general like the idea of having a 'skip' mechanism, but it does need to cost +something so people don't eat up the address space. 256 ^ 5 means you have a lot +of address space, but if people troll by skipping a lot that could be eaten up. +Should probably do some napkin calculations for how expensive skipping needs to +be to deter people from doing it just to chew up address space. +*) + +let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => { + let void: unit = + if (amount == storage.name_price) { (); } + else { failwith("Incorrect amount paid."); }; + let profile = parameter.profile; + let initial_controller = parameter.initial_controller; + let identities = storage.identities; + let new_id = storage.next_id; + let controller: address = + switch (initial_controller) { + | Some(addr) => addr + | None => sender + }; + let new_id_details: id_details = { + owner : sender, + controller : controller, + profile : profile, + }; + let updated_identities: big_map (id, id_details) = + Big_map.update(new_id, Some(new_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : new_id + 1, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let update_owner = ((parameter, storage): (update_owner, storage)) : (list(operation), storage) => { + let void: unit = + if (amount != 0mutez) { + failwith("Updating owner doesn't cost anything."); + } + else { (); }; + let id : int = parameter.id; + let new_owner = parameter.new_owner; + let identities = storage.identities; + let current_id_details: id_details = + switch (Big_map.find_opt(id, identities)) { + | Some(id_details) => id_details + | None => (failwith("This ID does not exist."): id_details) + }; + let is_allowed: bool = + if (sender == current_id_details.owner) { true; } + else { (failwith("You are not the owner of this ID."): bool); }; + let updated_id_details: id_details = { + owner : new_owner, + controller : current_id_details.controller, + profile : current_id_details.profile, + }; + let updated_identities = Big_map.update(id, (Some updated_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : storage.next_id, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let update_details = ((parameter, storage): (update_details, storage)) : + (list(operation), storage) => { + let void : unit = + if (amount != 0mutez) { + failwith("Updating details doesn't cost anything."); + } + else { (); }; + let id = parameter.id; + let new_profile = parameter.new_profile; + let new_controller = parameter.new_controller; + let identities = storage.identities; + let current_id_details: id_details = + switch (Big_map.find_opt(id, identities)) { + | Some(id_details) => id_details + | None => (failwith("This ID does not exist."): id_details) + }; + let is_allowed: bool = + if ((sender != current_id_details.controller) && + (sender != current_id_details.owner)) { + (failwith ("You are not the owner or controller of this ID."): bool) + } + else { true; }; + let owner: address = current_id_details.owner; + let profile: bytes = + switch (new_profile) { + | None => (* Default *) current_id_details.profile + | Some(new_profile) => new_profile + }; + let controller: address = + switch (new_controller) { + | None => (* Default *) current_id_details.controller + | Some new_controller => new_controller + }; + let updated_id_details: id_details = { + owner : owner, + controller : controller, + profile : profile, + }; + let updated_identities: big_map (id, id_details) = + Big_map.update(id, (Some updated_id_details), identities); + (([]: list(operation)), { + identities : updated_identities, + next_id : storage.next_id, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +(* Let someone skip the next identity so nobody has to take one that's undesirable *) +let skip = ((p,storage): (unit, storage)) => { + let void : unit = + if (amount != storage.skip_price) { + failwith("Incorrect amount paid."); + } + else { (); }; + (([]: list(operation)), { + identities : storage.identities, + next_id : storage.next_id + 1, + name_price : storage.name_price, + skip_price : storage.skip_price, + }); + }; + +let main = ((action, storage): (action, storage)) : (list(operation), storage) => { + switch (action) { + | Buy(b) => buy((b, storage)) + | Update_owner(uo) => update_owner((uo, storage)) + | Update_details ud => update_details((ud, storage)) + | Skip s => skip(((), storage)) + }; +}; diff --git a/src/test/id_tests_p.ml b/src/test/id_tests_p.ml index 81f08c556..6e45d4d1d 100644 --- a/src/test/id_tests_p.ml +++ b/src/test/id_tests_p.ml @@ -1,11 +1,10 @@ open Trace open Test_helpers -open Ast_simplified +open Ast_imperative -let mtype_file f = - let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "pascaligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in +let type_file f = + let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" Env in ok (typed,state) let get_program = @@ -13,14 +12,13 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = mtype_file "./contracts/id.ligo" in + let%bind program = type_file "./contracts/id.ligo" in s := Some program ; ok program ) let compile_main () = - let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/id.ligo" (Syntax_name "pascaligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = get_program () in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = @@ -96,7 +94,7 @@ let buy_id_sender_addr () = ("profile", new_website)] in let param = e_record_ez [("profile", owner_website) ; - ("initial_controller", (e_typed_none t_address))] in + ("initial_controller", (e_typed_none (t_address ())))] in let new_storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1) ; (e_int 1, id_details_2)])) ; @@ -324,8 +322,8 @@ let update_details_unchanged () = ("skip_price", e_mutez 1000000) ; ] in let param = e_record_ez [("id", e_int 1) ; - ("new_profile", e_typed_none t_bytes) ; - ("new_controller", e_typed_none t_address)] in + ("new_profile", e_typed_none (t_bytes ())) ; + ("new_controller", e_typed_none (t_address ()))] in let%bind () = expect_eq ~options program "update_details" (e_pair param storage) (e_pair (e_list []) storage) diff --git a/src/test/id_tests_r.ml b/src/test/id_tests_r.ml index d795134e1..0e5e273a6 100644 --- a/src/test/id_tests_r.ml +++ b/src/test/id_tests_r.ml @@ -1,11 +1,10 @@ open Trace open Test_helpers -open Ast_simplified +open Ast_imperative -let mtype_file f = - let%bind simplified = Ligo.Compile.Of_source.compile f (Syntax_name "reasonligo") in - let%bind typed,state = Ligo.Compile.Of_simplified.compile simplified in +let retype_file f = + let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" Env in ok (typed,state) let get_program = @@ -13,14 +12,13 @@ let get_program = fun () -> match !s with | Some s -> ok s | None -> ( - let%bind program = mtype_file "./contracts/id.religo" in + let%bind program = retype_file "./contracts/id.religo" in s := Some program ; ok program ) let compile_main () = - let%bind simplified = Ligo.Compile.Of_source.compile "./contracts/id.religo" (Syntax_name "reasonligo") in - let%bind typed_prg,_ = Ligo.Compile.Of_simplified.compile simplified in + let%bind typed_prg,_ = get_program () in let%bind mini_c_prg = Ligo.Compile.Of_typed.compile typed_prg in let%bind michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in let%bind (_contract: Tezos_utils.Michelson.michelson) = @@ -96,7 +94,7 @@ let buy_id_sender_addr () = ("profile", new_website)] in let param = e_record_ez [("profile", owner_website) ; - ("initial_controller", (e_typed_none t_address))] in + ("initial_controller", (e_typed_none (t_address ())))] in let new_storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1) ; (e_int 1, id_details_2)])) ; @@ -324,8 +322,8 @@ let update_details_unchanged () = ("skip_price", e_mutez 1000000) ; ] in let param = e_record_ez [("id", e_int 1) ; - ("new_profile", e_typed_none t_bytes) ; - ("new_controller", e_typed_none t_address)] in + ("new_profile", e_typed_none (t_bytes ())) ; + ("new_controller", e_typed_none (t_address ()))] in let%bind () = expect_eq ~options program "update_details" (e_pair param storage) (e_pair (e_list []) storage) diff --git a/tools/webide/packages/client/package-examples.js b/tools/webide/packages/client/package-examples.js index b6e2be960..1e1d83aea 100644 --- a/tools/webide/packages/client/package-examples.js +++ b/tools/webide/packages/client/package-examples.js @@ -109,6 +109,15 @@ async function main() { // const EXAMPLES_GLOB = '**/*.ligo'; // const files = await findFiles(EXAMPLES_GLOB, EXAMPLES_DIR); + const CURATED_EXAMPLES = [ + 'pascaligo/arithmetic-contract.ligo', + 'cameligo/arithmetic-contract.ligo', + 'reasonligo/arithmetic-contract.ligo', + 'pascaligo/id.ligo', + 'cameligo/id.mligo', + 'reasonligo/id.religo', + ]; + const EXAMPLES_DEST_DIR = join(process.cwd(), 'build', 'static', 'examples'); fs.mkdirSync(EXAMPLES_DEST_DIR, { recursive: true }); From 74dab76fb413a28d0a106914dde0aab91cedfefe Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 29 Apr 2020 09:23:15 +0200 Subject: [PATCH 24/32] optimizing contract --- src/test/contracts/id.ligo | 31 ++++++------------------------ src/test/contracts/id.mligo | 36 +++++++++++------------------------ src/test/contracts/id.religo | 37 ++++++++++-------------------------- 3 files changed, 27 insertions(+), 77 deletions(-) diff --git a/src/test/contracts/id.ligo b/src/test/contracts/id.ligo index 7f6418127..f4302dbfc 100644 --- a/src/test/contracts/id.ligo +++ b/src/test/contracts/id.ligo @@ -78,11 +78,9 @@ function buy (const parameter : buy; const storage : storage) : list(operation) profile = profile ; ]; identities[new_id] := new_id_details; - end with ((nil : list(operation)), record [ + end with ((nil : list(operation)), storage with record [ identities = identities; next_id = new_id + 1; - name_price = storage.name_price; - skip_price = storage.skip_price; ]) function update_owner (const parameter : update_owner; const storage : storage) : @@ -102,18 +100,12 @@ function update_owner (const parameter : update_owner; const storage : storage) Some(id_details) -> id_details | None -> (failwith("This ID does not exist."): id_details) end; - var is_allowed : bool := False; if sender = id_details.owner - then is_allowed := True + then skip; else failwith("You are not the owner of this ID."); id_details.owner := new_owner; identities[id] := id_details; - end with ((nil: list(operation)), record [ - identities = identities; - next_id = storage.next_id; - name_price = storage.name_price; - skip_price = storage.skip_price; - ]) + end with ((nil: list(operation)), storage with record [ identities = identities; ]) function update_details (const parameter : update_details; const storage : storage ) : list(operation) * storage is @@ -130,9 +122,8 @@ function update_details (const parameter : update_details; const storage : stora Some(id_details) -> id_details | None -> (failwith("This ID does not exist."): id_details) end; - var is_allowed : bool := False; if (sender = id_details.controller) or (sender = id_details.owner) - then is_allowed := True + then skip; else failwith("You are not the owner or controller of this ID."); const owner: address = id_details.owner; const profile: bytes = @@ -149,12 +140,7 @@ function update_details (const parameter : update_details; const storage : stora id_details.controller := controller; id_details.profile := profile; identities[id] := id_details; - end with ((nil: list(operation)), record [ - identities = identities; - next_id = storage.next_id; - name_price = storage.name_price; - skip_price = storage.skip_price; - ]) + end with ((nil: list(operation)), storage with record [ identities = identities; ]) (* Let someone skip the next identity so nobody has to take one that's undesirable *) function skip_ (const p: unit; const storage: storage) : list(operation) * storage is @@ -162,12 +148,7 @@ function skip_ (const p: unit; const storage: storage) : list(operation) * stora if amount = storage.skip_price then skip else failwith("Incorrect amount paid."); - end with ((nil: list(operation)), record [ - identities = storage.identities; - next_id = storage.next_id + 1; - name_price = storage.name_price; - skip_price = storage.skip_price; - ]) + end with ((nil: list(operation)), storage with record [ next_id = storage.next_id + 1; ]) function main (const action : action; const storage : storage) : list(operation) * storage is case action of diff --git a/src/test/contracts/id.mligo b/src/test/contracts/id.mligo index 67233ce56..88cb8d3dc 100644 --- a/src/test/contracts/id.mligo +++ b/src/test/contracts/id.mligo @@ -78,10 +78,8 @@ let buy (parameter, storage: buy * storage) = let updated_identities : (id, id_details) big_map = Big_map.update new_id (Some new_id_details) identities in - ([]: operation list), {identities = updated_identities; + ([]: operation list), {storage with identities = updated_identities; next_id = new_id + 1; - name_price = storage.name_price; - skip_price = storage.skip_price; } let update_owner (parameter, storage: update_owner * storage) = @@ -96,10 +94,10 @@ let update_owner (parameter, storage: update_owner * storage) = | Some id_details -> id_details | None -> (failwith "This ID does not exist.": id_details) in - let is_allowed: bool = + let u : unit = if sender = current_id_details.owner - then true - else (failwith "You are not the owner of this ID.": bool) + then () + else failwith "You are not the owner of this ID." in let updated_id_details: id_details = { owner = new_owner; @@ -108,11 +106,7 @@ let update_owner (parameter, storage: update_owner * storage) = } in let updated_identities = Big_map.update id (Some updated_id_details) identities in - ([]: operation list), {identities = updated_identities; - next_id = storage.next_id; - name_price = storage.name_price; - skip_price = storage.skip_price; - } + ([]: operation list), {storage with identities = updated_identities} let update_details (parameter, storage: update_details * storage) = if (amount <> 0mutez) @@ -127,10 +121,10 @@ let update_details (parameter, storage: update_details * storage) = | Some id_details -> id_details | None -> (failwith "This ID does not exist.": id_details) in - let is_allowed: bool = + let u : unit = if (sender = current_id_details.controller) || (sender = current_id_details.owner) - then true - else (failwith ("You are not the owner or controller of this ID."): bool) + then () + else failwith ("You are not the owner or controller of this ID.") in let owner: address = current_id_details.owner in let profile: bytes = @@ -151,24 +145,16 @@ let update_details (parameter, storage: update_details * storage) = in let updated_identities: (id, id_details) big_map = Big_map.update id (Some updated_id_details) identities in - ([]: operation list), {identities = updated_identities; - next_id = storage.next_id; - name_price = storage.name_price; - skip_price = storage.skip_price; - } + ([]: operation list), {storage with identities = updated_identities} (* Let someone skip the next identity so nobody has to take one that's undesirable *) let skip (p,storage: unit * storage) = let void: unit = if amount = storage.skip_price then () - else (failwith "Incorrect amount paid.": unit) + else failwith "Incorrect amount paid." in - ([]: operation list), {identities = storage.identities; - next_id = storage.next_id + 1; - name_price = storage.name_price; - skip_price = storage.skip_price; - } + ([]: operation list), {storage with next_id = storage.next_id + 1} let main (action, storage : action * storage) : return = match action with diff --git a/src/test/contracts/id.religo b/src/test/contracts/id.religo index d5814e211..661d544a0 100644 --- a/src/test/contracts/id.religo +++ b/src/test/contracts/id.religo @@ -72,11 +72,9 @@ let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => }; let updated_identities: big_map (id, id_details) = Big_map.update(new_id, Some(new_id_details), identities); - (([]: list(operation)), { + (([]: list(operation)), { ...storage, identities : updated_identities, next_id : new_id + 1, - name_price : storage.name_price, - skip_price : storage.skip_price, }); }; @@ -94,21 +92,16 @@ let update_owner = ((parameter, storage): (update_owner, storage)) : (list(opera | Some(id_details) => id_details | None => (failwith("This ID does not exist."): id_details) }; - let is_allowed: bool = - if (sender == current_id_details.owner) { true; } - else { (failwith("You are not the owner of this ID."): bool); }; + let u: unit = + if (sender == current_id_details.owner) { (); } + else { failwith("You are not the owner of this ID."); }; let updated_id_details: id_details = { owner : new_owner, controller : current_id_details.controller, profile : current_id_details.profile, }; let updated_identities = Big_map.update(id, (Some updated_id_details), identities); - (([]: list(operation)), { - identities : updated_identities, - next_id : storage.next_id, - name_price : storage.name_price, - skip_price : storage.skip_price, - }); + (([]: list(operation)), { ...storage, identities : updated_identities }); }; let update_details = ((parameter, storage): (update_details, storage)) : @@ -127,12 +120,12 @@ let update_details = ((parameter, storage): (update_details, storage)) : | Some(id_details) => id_details | None => (failwith("This ID does not exist."): id_details) }; - let is_allowed: bool = + let u: unit = if ((sender != current_id_details.controller) && (sender != current_id_details.owner)) { - (failwith ("You are not the owner or controller of this ID."): bool) + failwith ("You are not the owner or controller of this ID.") } - else { true; }; + else { (); }; let owner: address = current_id_details.owner; let profile: bytes = switch (new_profile) { @@ -151,12 +144,7 @@ let update_details = ((parameter, storage): (update_details, storage)) : }; let updated_identities: big_map (id, id_details) = Big_map.update(id, (Some updated_id_details), identities); - (([]: list(operation)), { - identities : updated_identities, - next_id : storage.next_id, - name_price : storage.name_price, - skip_price : storage.skip_price, - }); + (([]: list(operation)), { ...storage, identities : updated_identities }); }; /* Let someone skip the next identity so nobody has to take one that's undesirable */ @@ -166,12 +154,7 @@ let skip = ((p,storage): (unit, storage)) => { failwith("Incorrect amount paid."); } else { (); }; - (([]: list(operation)), { - identities : storage.identities, - next_id : storage.next_id + 1, - name_price : storage.name_price, - skip_price : storage.skip_price, - }); + (([]: list(operation)), { ...storage, next_id : storage.next_id + 1 }); }; let main = ((action, storage): (action, storage)) : (list(operation), storage) => { From 0c9aeeeb64be2ecaf25996c724f8940c1a59c3a1 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 29 Apr 2020 13:36:36 +0200 Subject: [PATCH 25/32] checking contracts --- src/test/id_tests_p.ml | 17 +++++++---------- src/test/id_tests_r.ml | 2 +- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/src/test/id_tests_p.ml b/src/test/id_tests_p.ml index 6e45d4d1d..106839c1b 100644 --- a/src/test/id_tests_p.ml +++ b/src/test/id_tests_p.ml @@ -4,7 +4,7 @@ open Ast_imperative let type_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" Env in + let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" (Contract "main") in ok (typed,state) let get_program = @@ -50,10 +50,9 @@ let buy_id () = ~sender:first_contract ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () in - let new_website = e_bytes_string "ligolang.org" in let id_details_2 = e_record_ez [("owner", e_address new_addr) ; ("controller", e_address new_addr) ; - ("profile", new_website)] + ("profile", owner_website)] in let param = e_record_ez [("profile", owner_website) ; ("initial_controller", (e_some (e_address new_addr))) ; @@ -88,10 +87,9 @@ let buy_id_sender_addr () = ~sender:first_contract ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () in - let new_website = e_bytes_string "ligolang.org" in let id_details_2 = e_record_ez [("owner", e_address new_addr) ; ("controller", e_address new_addr) ; - ("profile", new_website)] + ("profile", owner_website)] in let param = e_record_ez [("profile", owner_website) ; ("initial_controller", (e_typed_none (t_address ())))] in @@ -147,14 +145,13 @@ let update_details_owner () = ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) () in - let new_website = e_bytes_string "ligolang.org" in let id_details_2 = e_record_ez [("owner", e_address new_addr) ; ("controller", e_address owner_addr) ; - ("profile", new_website)] + ("profile", owner_website)] in let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ; ("controller", e_address new_addr) ; - ("profile", new_website)] in + ("profile", owner_website)] in let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1) ; (e_int 1, id_details_2)])) ; @@ -169,7 +166,7 @@ let update_details_owner () = ("name_price", e_mutez 1000000) ; ("skip_price", e_mutez 1000000) ; ] in - let details = e_bytes_string "ligolang.org" in + let details = owner_website in let param = e_record_ez [("id", e_int 1) ; ("new_profile", e_some details) ; ("new_controller", e_some (e_address new_addr))] in @@ -192,7 +189,7 @@ let update_details_controller () = ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.zero) () in - let new_website = e_bytes_string "ligolang.org" in + let new_website = owner_website in let id_details_2 = e_record_ez [("owner", e_address owner_addr) ; ("controller", e_address new_addr) ; ("profile", new_website)] diff --git a/src/test/id_tests_r.ml b/src/test/id_tests_r.ml index 0e5e273a6..fe8ee6595 100644 --- a/src/test/id_tests_r.ml +++ b/src/test/id_tests_r.ml @@ -4,7 +4,7 @@ open Ast_imperative let retype_file f = - let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" Env in + let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" (Contract "main") in ok (typed,state) let get_program = From 4d51aa62cbbc804f9c4bf5b3201d1ce5b145068c Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 29 Apr 2020 13:43:02 +0200 Subject: [PATCH 26/32] removing wrong dryRun and evaluateFunction in ide examples --- src/test/examples/cameligo/id.mligo | 7 ------- src/test/examples/pascaligo/id.ligo | 5 ----- src/test/examples/reasonligo/id.religo | 5 ----- 3 files changed, 17 deletions(-) diff --git a/src/test/examples/cameligo/id.mligo b/src/test/examples/cameligo/id.mligo index 2019eb815..660c50616 100644 --- a/src/test/examples/cameligo/id.mligo +++ b/src/test/examples/cameligo/id.mligo @@ -4,17 +4,10 @@ compile: entrypoint: main dryRun: - entrypoint: main - parameters: Increment 1 - storage: 0 deploy: - entrypoint: main - storage: 0 evaluateValue: entrypoint: "" evaluateFunction: - entrypoint: add - parameters: 5, 6 *_*) type id = int diff --git a/src/test/examples/pascaligo/id.ligo b/src/test/examples/pascaligo/id.ligo index ece089aa9..468449535 100644 --- a/src/test/examples/pascaligo/id.ligo +++ b/src/test/examples/pascaligo/id.ligo @@ -4,17 +4,12 @@ compile: entrypoint: main dryRun: - entrypoint: main - parameters: Increment 1 - storage: 0 deploy: entrypoint: main storage: 0 evaluateValue: entrypoint: "" evaluateFunction: - entrypoint: add - parameters: 5, 6 *_*) type id is int diff --git a/src/test/examples/reasonligo/id.religo b/src/test/examples/reasonligo/id.religo index 3177c8fa5..715aec10d 100644 --- a/src/test/examples/reasonligo/id.religo +++ b/src/test/examples/reasonligo/id.religo @@ -4,17 +4,12 @@ compile: entrypoint: main dryRun: - entrypoint: main - parameters: Increment 1 - storage: 0 deploy: entrypoint: main storage: 0 evaluateValue: entrypoint: "" evaluateFunction: - entrypoint: add - parameters: 5, 6 *_*) type id = int From fa1185c20ed8653e9d2c0178590b42d0f9c081b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jev=20Bj=C3=B6rsell?= Date: Tue, 19 May 2020 13:15:23 -0700 Subject: [PATCH 27/32] Add new ID example contracts to dev initial state Remove duplicate def of CURATED_EXAMPLES --- tools/webide/packages/client/package-examples.js | 6 ------ tools/webide/packages/client/src/redux/examples.ts | 11 +++++++---- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/tools/webide/packages/client/package-examples.js b/tools/webide/packages/client/package-examples.js index 1e1d83aea..2d7b7dbf4 100644 --- a/tools/webide/packages/client/package-examples.js +++ b/tools/webide/packages/client/package-examples.js @@ -4,12 +4,6 @@ const join = require('path').join; const fs = require('fs'); const YAML = require('yamljs'); -const CURATED_EXAMPLES = [ - 'cameligo/arithmetic-contract.ligo', - 'pascaligo/arithmetic-contract.ligo', - 'reasonligo/arithmetic-contract.ligo' -]; - function urlFriendlyHash(content) { const hash = createHash('md5'); hash.update(content); diff --git a/tools/webide/packages/client/src/redux/examples.ts b/tools/webide/packages/client/src/redux/examples.ts index 7e631cbc9..43ec23f1a 100644 --- a/tools/webide/packages/client/src/redux/examples.ts +++ b/tools/webide/packages/client/src/redux/examples.ts @@ -17,7 +17,7 @@ export interface ExamplesState { export class ChangeSelectedAction { public readonly type = ActionType.ChangeSelected; - constructor(public payload: ExamplesState['selected']) {} + constructor(public payload: ExamplesState['selected']) { } } export class ClearSelectedAction { @@ -33,9 +33,12 @@ export const DEFAULT_STATE: ExamplesState = { if (process.env.NODE_ENV === 'development') { DEFAULT_STATE.list = [ - { id: 'MzkMQ1oiVHJqbcfUuVFKTw', name: 'CameLIGO Contract' }, - { id: 'FEb62HL7onjg1424eUsGSg', name: 'PascaLIGO Contract' }, - { id: 'JPhSOehj_2MFwRIlml0ymQ', name: 'ReasonLIGO Contract' } + { id: 'MzkMQ1oiVHJqbcfUuVFKTw', name: 'Increment Example CameLIGO ' }, + { id: 'FEb62HL7onjg1424eUsGSg', name: 'Increment Example PascaLIGO' }, + { id: 'JPhSOehj_2MFwRIlml0ymQ', name: 'Increment Example ReasonLIGO' }, + { id: 'ehDv-Xaf70mQoiPhQDTAUQ', name: 'ID Example CameLIGO' }, + { id: 'CpnK7TFuUjJiQTT8KiiGyQ', name: 'ID Example ReasonLIGO' }, + { id: 'yP-THvmURsaqHxpwCravWg', name: 'ID Example PascaLIGO' }, ]; } From 5b398b47c293d17998c70c9a46d18e12ba771710 Mon Sep 17 00:00:00 2001 From: technomad21c Date: Thu, 21 May 2020 19:04:17 -0700 Subject: [PATCH 28/32] add an ID Contract example --- src/test/examples/pascaligo/id.ligo | 34 ++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/test/examples/pascaligo/id.ligo b/src/test/examples/pascaligo/id.ligo index 468449535..887d64d6d 100644 --- a/src/test/examples/pascaligo/id.ligo +++ b/src/test/examples/pascaligo/id.ligo @@ -4,12 +4,44 @@ compile: entrypoint: main dryRun: + entrypoint: main + parameters: | + Buy ( + record [ + profile=0x0501000000026869; + initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)) + ] + ) + storage: | + record [ + identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869]]; + next_id=2; + name_price=0tez; + skip_price=50mutez; + ] deploy: entrypoint: main - storage: 0 + storage: evaluateValue: entrypoint: "" evaluateFunction: + entrypoint: buy + parameters: | + ( + record [ + profile=0x0501000000026869; + initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)) + ], + + record [ identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869]]; + next_id=2; + name_price=0tez; + skip_price=333mutez; + ] + ) *_*) type id is int From f29cf5a61281e7297cfe5e135943b8d7b1059c8a Mon Sep 17 00:00:00 2001 From: technomad21c Date: Fri, 22 May 2020 14:23:39 -0700 Subject: [PATCH 29/32] add the ID Contract example for cameligo and reasonligo --- src/test/examples/cameligo/id.mligo | 31 ++++++++++++++++ src/test/examples/reasonligo/id.religo | 49 +++++++++++++++++++++----- 2 files changed, 71 insertions(+), 9 deletions(-) diff --git a/src/test/examples/cameligo/id.mligo b/src/test/examples/cameligo/id.mligo index 660c50616..8ae86b16d 100644 --- a/src/test/examples/cameligo/id.mligo +++ b/src/test/examples/cameligo/id.mligo @@ -4,10 +4,41 @@ compile: entrypoint: main dryRun: + entrypoint: main + parameters: | + Buy ( + { + profile=0x0501000000026869; + initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)) + } + ) + storage: | + { + identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869});]; + next_id=2; + name_price=0tez; + skip_price=333mutez + } + deploy: evaluateValue: entrypoint: "" evaluateFunction: + entrypoint: buy + parameters: | + { + profile=0x0501000000026869; + initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)) + }, + + { + identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869});]; + next_id=2; + name_price=0tez; + skip_price=333mutez + } *_*) type id = int diff --git a/src/test/examples/reasonligo/id.religo b/src/test/examples/reasonligo/id.religo index 715aec10d..456439a0c 100644 --- a/src/test/examples/reasonligo/id.religo +++ b/src/test/examples/reasonligo/id.religo @@ -1,16 +1,47 @@ -(*_* +/* (*_* name: ID Contract (ReasonLIGO) language: reasonligo compile: entrypoint: main dryRun: + entrypoint: main + parameters: | + Buy ( + { + profile: 0x0501000000026869, initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address)) + } + ) + storage: | + { + identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), + controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869})]), + next_id:2, + name_price:0tez, + skip_price:333mutez + } deploy: entrypoint: main storage: 0 evaluateValue: entrypoint: "" evaluateFunction: -*_*) + entrypoint: buy + parameters: | + ( + { + profile: 0x0501000000026869, + initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address)) + }, + { + identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), + controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), + profile:0x0501000000026869})]), + next_id:2, + name_price:0tez, + skip_price:333mutez + } + ) +*_*) */ type id = int @@ -42,8 +73,8 @@ type action = | Update_details(update_details) | Skip(unit) -(* The prices kept in storage can be changed by bakers, though they should only be - adjusted down over time, not up. *) +/* The prices kept in storage can be changed by bakers, though they should only be + adjusted down over time, not up. */ type storage = { identities: big_map (id, id_details), next_id: int, @@ -51,7 +82,7 @@ type storage = { skip_price: tez, } -(** Preliminary thoughts on ids: +/** Preliminary thoughts on ids: I very much like the simplicity of http://gurno.com/adam/mne/. 5 three letter words means you have a 15 character identity, not actually more @@ -64,7 +95,7 @@ something so people don't eat up the address space. 256 ^ 5 means you have a lot of address space, but if people troll by skipping a lot that could be eaten up. Should probably do some napkin calculations for how expensive skipping needs to be to deter people from doing it just to chew up address space. -*) +*/ let buy = ((parameter, storage): (buy, storage)) : (list(operation), storage) => { let void: unit = @@ -150,12 +181,12 @@ let update_details = ((parameter, storage): (update_details, storage)) : let owner: address = current_id_details.owner; let profile: bytes = switch (new_profile) { - | None => (* Default *) current_id_details.profile + | None => /* Default */ current_id_details.profile | Some(new_profile) => new_profile }; let controller: address = switch (new_controller) { - | None => (* Default *) current_id_details.controller + | None => /* Default */ current_id_details.controller | Some new_controller => new_controller }; let updated_id_details: id_details = { @@ -173,7 +204,7 @@ let update_details = ((parameter, storage): (update_details, storage)) : }); }; -(* Let someone skip the next identity so nobody has to take one that's undesirable *) +/* Let someone skip the next identity so nobody has to take one that's undesirable */ let skip = ((p,storage): (unit, storage)) => { let void : unit = if (amount != storage.skip_price) { From a5419d01581081b347536f71537dfd3b78071fed Mon Sep 17 00:00:00 2001 From: technomad21c Date: Tue, 26 May 2020 10:01:40 -0700 Subject: [PATCH 30/32] add default parameters for deploy and modify the hashvalue for share-link test --- src/test/examples/cameligo/id.mligo | 8 +++++++- src/test/examples/pascaligo/id.ligo | 9 ++++++++- src/test/examples/reasonligo/id.religo | 7 ++++++- tools/webide/packages/e2e/test/share.spec.js | 2 +- 4 files changed, 22 insertions(+), 4 deletions(-) diff --git a/src/test/examples/cameligo/id.mligo b/src/test/examples/cameligo/id.mligo index 8ae86b16d..cdce7161f 100644 --- a/src/test/examples/cameligo/id.mligo +++ b/src/test/examples/cameligo/id.mligo @@ -19,8 +19,14 @@ name_price=0tez; skip_price=333mutez } - deploy: + entrypoint: main + storage: | + { + identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869});]; + next_id=2; + name_price=10tez; + skip_price=333mutez} evaluateValue: entrypoint: "" evaluateFunction: diff --git a/src/test/examples/pascaligo/id.ligo b/src/test/examples/pascaligo/id.ligo index 887d64d6d..5178916bd 100644 --- a/src/test/examples/pascaligo/id.ligo +++ b/src/test/examples/pascaligo/id.ligo @@ -22,7 +22,14 @@ ] deploy: entrypoint: main - storage: + storage: | + record [ + identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869]]; + next_id=2; + name_price=0tez; + skip_price=50mutez; + ] evaluateValue: entrypoint: "" evaluateFunction: diff --git a/src/test/examples/reasonligo/id.religo b/src/test/examples/reasonligo/id.religo index 456439a0c..b399cba1b 100644 --- a/src/test/examples/reasonligo/id.religo +++ b/src/test/examples/reasonligo/id.religo @@ -21,7 +21,12 @@ } deploy: entrypoint: main - storage: 0 + storage: | + { + identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869})]), + next_id:2, + name_price:10tez, + skip_price:333mutez} evaluateValue: entrypoint: "" evaluateFunction: diff --git a/tools/webide/packages/e2e/test/share.spec.js b/tools/webide/packages/e2e/test/share.spec.js index dd73d64db..2cece1c97 100644 --- a/tools/webide/packages/e2e/test/share.spec.js +++ b/tools/webide/packages/e2e/test/share.spec.js @@ -24,7 +24,7 @@ describe('Share', () => { await responseCallback; const actualShareLink = await page.evaluate(getInputValue, 'share-link'); - const expectedShareLink = `${API_HOST}/p/WxKPBq9-mkZ_kq4cMHXfCQ`; + const expectedShareLink = `${API_HOST}/p/2GnQR0cUYeO7feAw71SJYQ` expect(actualShareLink).toEqual(expectedShareLink); done(); From 9d0da34f965155e209a1d970d4ec77b0afba0d1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jev=20Bj=C3=B6rsell?= Date: Thu, 28 May 2020 11:40:05 -0700 Subject: [PATCH 31/32] Improve formatting of default webide values --- src/test/examples/cameligo/id.mligo | 36 ++++++++++++++----- src/test/examples/pascaligo/id.ligo | 25 ++++++++++---- src/test/examples/reasonligo/id.religo | 48 +++++++++++++++++--------- 3 files changed, 76 insertions(+), 33 deletions(-) diff --git a/src/test/examples/cameligo/id.mligo b/src/test/examples/cameligo/id.mligo index cdce7161f..9f9fabac9 100644 --- a/src/test/examples/cameligo/id.mligo +++ b/src/test/examples/cameligo/id.mligo @@ -14,7 +14,13 @@ ) storage: | { - identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869});]; + identities=Big_map.literal[ + (1, + {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869} + ); + ]; next_id=2; name_price=0tez; skip_price=333mutez @@ -23,10 +29,17 @@ entrypoint: main storage: | { - identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869});]; + identities=Big_map.literal[ + (1, + {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869} + ); + ]; next_id=2; name_price=10tez; - skip_price=333mutez} + skip_price=333mutez + } evaluateValue: entrypoint: "" evaluateFunction: @@ -38,9 +51,13 @@ }, { - identities=Big_map.literal[(1, {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); - controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); - profile=0x0501000000026869});]; + identities=Big_map.literal[ + (1, + {owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869} + ); + ]; next_id=2; name_price=0tez; skip_price=333mutez @@ -88,13 +105,14 @@ type storage = { (** Preliminary thoughts on ids: -I very much like the simplicity of http://gurno.com/adam/mne/. -5 three letter words means you have a 15 character identity, not actually more +I very much like the simplicity of http://gurno.com/adam/mne/ + +Five three letter words means you have a 15 character identity, not actually more annoying than an IP address and a lot more memorable than the raw digits. This can be stored as a single integer which is then translated into the corresponding series of 5 words. -I in general like the idea of having a 'skip' mechanism, but it does need to cost +I, in general like the idea of having a 'skip' mechanism, but it does need to cost something so people don't eat up the address space. 256 ^ 5 means you have a lot of address space, but if people troll by skipping a lot that could be eaten up. Should probably do some napkin calculations for how expensive skipping needs to diff --git a/src/test/examples/pascaligo/id.ligo b/src/test/examples/pascaligo/id.ligo index 5178916bd..a0023e201 100644 --- a/src/test/examples/pascaligo/id.ligo +++ b/src/test/examples/pascaligo/id.ligo @@ -14,8 +14,12 @@ ) storage: | record [ - identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); - controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869]]; + identities=big_map[ + 1->record + [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869] + ]; next_id=2; name_price=0tez; skip_price=50mutez; @@ -24,8 +28,12 @@ entrypoint: main storage: | record [ - identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); - controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); profile=0x0501000000026869]]; + identities=big_map[ + 1->record + [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869] + ]; next_id=2; name_price=0tez; skip_price=50mutez; @@ -41,9 +49,12 @@ initial_controller=Some(("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address)) ], - record [ identities=big_map[1->record [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); - controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); - profile=0x0501000000026869]]; + record [ identities=big_map[ + 1->record + [owner=("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address); + controller=("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address); + profile=0x0501000000026869] + ]; next_id=2; name_price=0tez; skip_price=333mutez; diff --git a/src/test/examples/reasonligo/id.religo b/src/test/examples/reasonligo/id.religo index b399cba1b..9131a9080 100644 --- a/src/test/examples/reasonligo/id.religo +++ b/src/test/examples/reasonligo/id.religo @@ -7,26 +7,36 @@ entrypoint: main parameters: | Buy ( - { - profile: 0x0501000000026869, initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address)) + { + profile: 0x0501000000026869, + initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address)) } ) storage: | { - identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), - controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869})]), - next_id:2, - name_price:0tez, + identities:Big_map.literal([ + (1, + {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), + controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869} + ) + ]), + next_id:2, + name_price:0tez, skip_price:333mutez } deploy: entrypoint: main storage: | { - identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869})]), - next_id:2, - name_price:10tez, - skip_price:333mutez} + identities:Big_map.literal([ + (1, + {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), profile:0x0501000000026869} + ) + ]), + next_id:2, + name_price:10tez, + skip_price:333mutez + } evaluateValue: entrypoint: "" evaluateFunction: @@ -34,15 +44,19 @@ parameters: | ( { - profile: 0x0501000000026869, + profile: 0x0501000000026869, initial_controller: Some(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address)) }, { - identities:Big_map.literal([(1, {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), - controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), - profile:0x0501000000026869})]), - next_id:2, - name_price:0tez, + identities:Big_map.literal([ + (1, + {owner:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address), + controller:("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx": address), + profile:0x0501000000026869} + ) + ]), + next_id:2, + name_price:0tez, skip_price:333mutez } ) @@ -163,7 +177,7 @@ let update_owner = ((parameter, storage): (update_owner, storage)) : (list(opera let update_details = ((parameter, storage): (update_details, storage)) : (list(operation), storage) => { - let void : unit = + let void : unit = if (amount != 0mutez) { failwith("Updating details doesn't cost anything."); } From 267e2821746110538f9d2f190d91e22b63b0deb1 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 2 Jun 2020 17:02:16 +0200 Subject: [PATCH 32/32] rebase --- src/test/id_tests_p.ml | 28 ++++++++++++++-------------- src/test/id_tests_r.ml | 26 +++++++++++++------------- 2 files changed, 27 insertions(+), 27 deletions(-) diff --git a/src/test/id_tests_p.ml b/src/test/id_tests_p.ml index 106839c1b..714af1c39 100644 --- a/src/test/id_tests_p.ml +++ b/src/test/id_tests_p.ml @@ -33,7 +33,7 @@ let (first_owner , first_contract) = Protocol.Alpha_context.Contract.to_b58check kt , kt let buy_id () = - let%bind program, _ = get_program () in + let%bind program, state = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -64,13 +64,13 @@ let buy_id () = ("name_price", e_mutez 1000000) ; ("skip_price", e_mutez 1000000) ; ] in - let%bind () = expect_eq ~options program "buy" + let%bind () = expect_eq ~options (program, state) "buy" (e_pair param storage) (e_pair (e_list []) new_storage) in ok () let buy_id_sender_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -107,7 +107,7 @@ let buy_id_sender_addr () = (* Test that contract fails if we attempt to buy an ID for the wrong amount *) let buy_id_wrong_amount () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -132,7 +132,7 @@ let buy_id_wrong_amount () = in ok () let update_details_owner () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -176,7 +176,7 @@ let update_details_owner () = in ok () let update_details_controller () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -222,7 +222,7 @@ let update_details_controller () = (* Test that contract fails when we attempt to update details of nonexistent ID *) let update_details_nonexistent () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -258,7 +258,7 @@ let update_details_nonexistent () = (* Test that contract fails when we attempt to update details from wrong addr *) let update_details_wrong_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -293,7 +293,7 @@ let update_details_wrong_addr () = (* Test that giving none on both profile and controller address is a no-op *) let update_details_unchanged () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -327,7 +327,7 @@ let update_details_unchanged () = in ok () let update_owner () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -371,7 +371,7 @@ let update_owner () = (* Test that contract fails when we attempt to update owner of nonexistent ID *) let update_owner_nonexistent () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -405,7 +405,7 @@ let update_owner_nonexistent () = (* Test that contract fails when we attempt to update owner from non-owner addr *) let update_owner_wrong_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -438,7 +438,7 @@ let update_owner_wrong_addr () = in ok () let skip () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -476,7 +476,7 @@ let skip () = (* Test that contract fails if we try to skip without paying the right amount *) let skip_wrong_amount () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; diff --git a/src/test/id_tests_r.ml b/src/test/id_tests_r.ml index fe8ee6595..d36c84929 100644 --- a/src/test/id_tests_r.ml +++ b/src/test/id_tests_r.ml @@ -33,7 +33,7 @@ let (first_owner , first_contract) = Protocol.Alpha_context.Contract.to_b58check kt , kt let buy_id () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -71,7 +71,7 @@ let buy_id () = in ok () let buy_id_sender_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -109,7 +109,7 @@ let buy_id_sender_addr () = (* Test that contract fails if we attempt to buy an ID for the wrong amount *) let buy_id_wrong_amount () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -134,7 +134,7 @@ let buy_id_wrong_amount () = in ok () let update_details_owner () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -179,7 +179,7 @@ let update_details_owner () = in ok () let update_details_controller () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -225,7 +225,7 @@ let update_details_controller () = (* Test that contract fails when we attempt to update details of nonexistent ID *) let update_details_nonexistent () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -261,7 +261,7 @@ let update_details_nonexistent () = (* Test that contract fails when we attempt to update details from wrong addr *) let update_details_wrong_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -296,7 +296,7 @@ let update_details_wrong_addr () = (* Test that giving none on both profile and controller address is a no-op *) let update_details_unchanged () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -330,7 +330,7 @@ let update_details_unchanged () = in ok () let update_owner () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -374,7 +374,7 @@ let update_owner () = (* Test that contract fails when we attempt to update owner of nonexistent ID *) let update_owner_nonexistent () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -408,7 +408,7 @@ let update_owner_nonexistent () = (* Test that contract fails when we attempt to update owner from non-owner addr *) let update_owner_wrong_addr () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -441,7 +441,7 @@ let update_owner_wrong_addr () = in ok () let skip () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; @@ -479,7 +479,7 @@ let skip () = (* Test that contract fails if we try to skip without paying the right amount *) let skip_wrong_amount () = - let%bind program, _ = get_program () in + let%bind program = get_program () in let owner_addr = addr 5 in let owner_website = e_bytes_string "ligolang.org" in let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;