balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'dev' of gitlab.com:edmondlee/ligo into webide/generate-deploy-script

Browse Source
This commit is contained in:
Edmond Lee 2020-06-02 10:29:06 -07:00
commit 08ee216f1b
78 changed files with 3524 additions and 2100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitlab-ci.yml
View File

@ -63,12 +63,14 @@ test:
- /^.*-run-dev$/ - /^.*-run-dev$/
script: script:
- nix-build nix -A ligo-coverage - nix-build nix -A ligo-coverage
- cat result/share/coverage-all
- cp -Lr --no-preserve=mode,ownership,timestamps result/share/coverage . - cp -Lr --no-preserve=mode,ownership,timestamps result/share/coverage .
artifacts: artifacts:
paths: paths:
- coverage - coverage
webide-e2e: # Strange race conditions, disable for now
.webide-e2e:
extends: .nix extends: .nix
only: only:
- merge_requests - merge_requests

47
gitlab-pages/docs/language-basics/maps-records.md
View File

@ -5,12 +5,12 @@ title: Records and Maps
import Syntax from '@theme/Syntax'; 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*. complex built-in constructs, such as *records* and *maps*.
## Records ## 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 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 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 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. Let us first consider and example of record type declaration.
<Syntax syntax="pascaligo"> <Syntax syntax="pascaligo">
```pascaligo group=records1 ```pascaligo group=records1
@ -55,10 +53,8 @@ type user = {
</Syntax> </Syntax>
And here is how a record value is defined: And here is how a record value is defined:
<Syntax syntax="pascaligo"> <Syntax syntax="pascaligo">
```pascaligo group=records1 ```pascaligo group=records1
@ -142,7 +138,7 @@ points on a plane.
In PascaLIGO, the shape of that expression is In PascaLIGO, the shape of that expression is
`<record variable> with <record value>`. `<record variable> with <record value>`.
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. record value is the update itself.
```pascaligo group=records2 ```pascaligo group=records2
@ -160,13 +156,13 @@ following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.ligo 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} # Outputs: {z = 1 , y = 7 , x = 5}
``` ```
You have to understand that `p` has not been changed by the functional 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 update: a nameless new version of it has been created and returned by
the blockless function. the block-less function.
</Syntax> </Syntax>
<Syntax syntax="cameligo"> <Syntax syntax="cameligo">
@ -186,6 +182,7 @@ let xy_translate (p, vec : point * vector) : point =
You can call the function `xy_translate` defined above by running the You can call the function `xy_translate` defined above by running the
following command of the shell: following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.mligo 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 You can call the function `xy_translate` defined above by running the
following command of the shell: following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_update.religo 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 Note that all the records in the path will get updated. In this example that's
`account` and `preferences`. `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]]
```
<Syntax syntax="pascaligo"> <Syntax syntax="pascaligo">
### Record Patches ### Record Patches
Another way to understand what it means to update a record value is to 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 exhibit the modification. This is called a `patch` and this is only
possible in PascaLIGO, because a patch is an *instruction*, therefore possible in PascaLIGO, because a patch is an *instruction*, therefore
we can only use it in a block. Similarly to a *functional update*, a 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 You can call the function `xy_translate` defined above by running the
following command of the shell: following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_patch.ligo 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 You can call the new function `xy_translate` defined above by running the
following command of the shell: following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_patch2.ligo 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 You can call the new function `xy_translate` defined above by running the
following command of the shell: following command of the shell:
```shell ```shell
ligo run-function ligo run-function
gitlab-pages/docs/language-basics/src/maps-records/record_simu.ligo 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 Here is how a custom map from addresses to a pair of integers is
defined. defined.
<Syntax syntax="pascaligo"> <Syntax syntax="pascaligo">
```pascaligo group=maps ```pascaligo group=maps
@ -680,8 +688,8 @@ let assign = (m : register) : register =>
(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), Some ((4,9)), m); (("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), Some ((4,9)), m);
``` ```
Notice the optional value `Some (4,9)` instead of `(4,9)`. If we had Notice the optional value `Some (4,9)` instead of `(4,9)`. If we used
use `None` instead, that would have meant that the binding is removed. `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. As a particular case, we can only add a key and its associated value.
@ -693,7 +701,6 @@ let add = (m : register) : register =>
</Syntax> </Syntax>
To remove a binding from a map, we need its key. 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 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 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 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. of a map is within a certain range and fail with an error otherwise.
The predefined functional iterator implementing the iterated operation The predefined functional iterator implementing the iterated operation
over maps is called `Map.iter`. In the following example, the register over maps is called `Map.iter`. In the following example, the register
@ -985,7 +992,7 @@ let moves : register =
(("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address), (0,3))] (("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 `(<key>, <value>)`. Note also the semicolon list of key-value pairs `(<key>, <value>)`. Note also the semicolon
separating individual map entries. The annotated value `("<string> separating individual map entries. The annotated value `("<string>
value>" : address)` means that we cast a string into an address. value>" : address)` means that we cast a string into an address.
@ -1000,7 +1007,7 @@ let moves : register =
("tz1gjaF81ZRRvdzjobyfVNsAeSC6PScjfQwN" : address, (0,3))]); ("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 `(<key>, <value>)`. Note also the semicolon list of key-value pairs `(<key>, <value>)`. Note also the semicolon
separating individual map entries. The annotated value `("<string> separating individual map entries. The annotated value `("<string>
value>" : address)` means that we cast a string into an address. value>" : address)` means that we cast a string into an address.

5
nix/ocaml-overlay.nix
View File

@ -133,19 +133,16 @@ in {
echo "Coverage:" echo "Coverage:"
BISECT_ENABLE=yes dune runtest --force BISECT_ENABLE=yes dune runtest --force
bisect-ppx-report html -o $out/share/coverage/all --title="LIGO overall test coverage" 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:" echo "Test coverage:"
BISECT_ENABLE=yes dune runtest src/test --force BISECT_ENABLE=yes dune runtest src/test --force
bisect-ppx-report html -o $out/share/coverage/ligo --title="LIGO test coverage" bisect-ppx-report html -o $out/share/coverage/ligo --title="LIGO test coverage"
bisect-ppx-report summary --per-file
echo "Doc coverage:" echo "Doc coverage:"
BISECT_ENABLE=yes dune build @doc-test --force BISECT_ENABLE=yes dune build @doc-test --force
bisect-ppx-report html -o $out/share/coverage/docs --title="LIGO doc coverage" bisect-ppx-report html -o $out/share/coverage/docs --title="LIGO doc coverage"
bisect-ppx-report summary --per-file
echo "CLI test coverage:" echo "CLI test coverage:"
BISECT_ENABLE=yes dune runtest src/bin/expect_tests 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 html -o $out/share/coverage/cli --title="CLI test coverage"
bisect-ppx-report summary --per-file
''; '';
installPhase = "true"; installPhase = "true";
}); });

10
src/bin/cli.ml
View File

@ -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 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 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 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) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in Compile.Of_michelson.build_contract michelson_prg in
@ -290,7 +290,7 @@ let interpret =
| Some init_file -> | Some init_file ->
let%bind typed_prg,state = Compile.Utils.type_file init_file syntax Env in 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%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) ok (mini_c_prg,state,env)
| None -> ok ([],Typer.Solver.initial_state,Environment.default) in | 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 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 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 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) = let%bind (_contract: Tezos_utils.Michelson.michelson) =
(* fails if the given entry point is not a valid contract *) (* fails if the given entry point is not a valid contract *)
Compile.Of_michelson.build_contract michelson_prg in 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 = let f source_file entry_point storage input amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax (Contract entry_point) in 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 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 michelson_prg = Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg entry_point in
let%bind (_contract: Tezos_utils.Michelson.michelson) = 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 = let f source_file entry_point parameter amount balance sender source predecessor_timestamp syntax display_format =
toplevel ~display_format @@ toplevel ~display_format @@
let%bind typed_prg,state = Compile.Utils.type_file source_file syntax Env in 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 let%bind mini_c_prg = Compile.Of_typed.compile typed_prg in

4
src/bin/expect_tests/contract_tests.ml
View File

@ -7,7 +7,7 @@ let bad_contract basename =
let%expect_test _ = let%expect_test _ =
run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ; run_ligo_good [ "measure-contract" ; contract "coase.ligo" ; "main" ] ;
[%expect {| 1700 bytes |}] ; [%expect {| 1668 bytes |}] ;
run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ; run_ligo_good [ "measure-contract" ; contract "multisig.ligo" ; "main" ] ;
[%expect {| 995 bytes |}] ; [%expect {| 995 bytes |}] ;
@ -276,7 +276,7 @@ let%expect_test _ =
DIG 7 ; DIG 7 ;
DUP ; DUP ;
DUG 8 ; DUG 8 ;
NONE (pair (address %card_owner) (nat %card_pattern)) ; NONE (pair address nat) ;
SWAP ; SWAP ;
UPDATE ; UPDATE ;
DIG 2 ; DIG 2 ;

6
src/environment/bool.ml
View File

@ -1,4 +1,8 @@
open Ast_typed open Ast_typed
open Stage_common.Constant 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});
]

14
src/passes/10-interpreter/interpreter.ml
View File

@ -368,19 +368,23 @@ and eval : Ast_typed.expression -> env -> value result
let dummy : Ast_typed.program -> string result = let dummy : Ast_typed.program -> string result =
fun prg -> fun prg ->
let%bind (res,_) = bind_fold_list let aux (pp,top_env) el =
(fun (pp,top_env) el -> match Location.unwrap el with
let (Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _}) = Location.unwrap el in | Ast_typed.Declaration_constant {binder; expr ; inline=_ ; _} ->
let%bind v = let%bind v =
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
try try
eval expr top_env eval expr top_env
with Temporary_hack s -> ok @@ V_Failure s with Temporary_hack s ->
ok (V_Failure s)
(*TODO This TRY-CATCH is here until we properly implement effects*) (*TODO This TRY-CATCH is here until we properly implement effects*)
in in
let pp' = pp^"\n val "^(Var.to_name binder)^" = "^(Ligo_interpreter.PP.pp_value v) 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 let top_env' = Env.extend top_env (binder, v) in
ok @@ (pp',top_env') 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 ("",Env.empty_env) prg in
ok @@ res ok @@ res

26
src/passes/10-transpiler/transpiler.ml
View File

@ -374,9 +374,6 @@ let rec transpile_literal : AST.literal -> value = fun l -> match l with
| Literal_unit -> D_unit | Literal_unit -> D_unit
| Literal_void -> D_none | 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 -> 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%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 let kt_list = List.map (fun (k,({ctor_type;_}:AST.ctor_content)) -> (k,ctor_type)) (kv_list_of_cmap map_tv) in
@ -397,11 +394,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result')) return (E_let_in ((let_binder, rhs'.type_expression), inline, rhs', result'))
| E_literal l -> return @@ E_literal (transpile_literal l) | E_literal l -> return @@ E_literal (transpile_literal l)
| E_variable name -> ( | E_variable name -> (
let%bind ele = return @@ E_variable (name)
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)
) )
| E_application {lamb; args} -> | E_application {lamb; args} ->
let%bind a = transpile_annotated_expression lamb in let%bind a = transpile_annotated_expression lamb in
@ -441,7 +434,6 @@ and transpile_annotated_expression (ae:AST.expression) : expression result =
return ~tv ae return ~tv ae
) )
| E_record m -> ( | 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 node = Append_tree.of_list @@ Ast_typed.Helpers.list_of_record_or_tuple m in
let aux a b : expression result = let aux a b : expression result =
let%bind a = a in let%bind a = a in
@ -759,25 +751,29 @@ 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 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 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 match d with
| Declaration_constant { binder ; expr ; inline ; post_env=_ } -> | Declaration_constant { binder ; expr ; inline } ->
let%bind expression = transpile_annotated_expression expr in let%bind expression = transpile_annotated_expression expr in
let tv = Combinators.Expression.get_type expression in let tv = Combinators.Expression.get_type expression in
let env' = Environment.add (binder, tv) env 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 transpile_program (lst : AST.program) : program result =
let aux (prev:(toplevel_statement list * Environment.t) result) cur = let aux (prev:(toplevel_statement list * Environment.t) result) cur =
let%bind (hds, env) = prev in let%bind (hds, env) = prev in
let%bind ((_, env') as cur') = transpile_declaration env cur in match%bind transpile_declaration env cur with
ok (hds @ [ cur' ], env'.post_environment) | Some ((_ , env') as cur') -> ok (hds @ [ cur' ] , env'.post_environment)
| None -> ok (hds , env)
in in
let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in
ok statements ok statements
(* check whether the storage contains a big_map, if yes, check that (* 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 check_storage f ty loc : (anon_function * _) result =
let rec aux (t:type_expression) on_big_map = let rec aux (t:type_expression) on_big_map =
match t.type_content with match t.type_content with

10
src/passes/10-transpiler/untranspiler.ml
View File

@ -42,19 +42,19 @@ open Errors
let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result = let rec untranspile (v : value) (t : AST.type_expression) : AST.expression result =
let open! AST in 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 match t.type_content with
| T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> ( | T_variable (name) when Var.equal name Stage_common.Constant.t_bool -> (
let%bind b = let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@ trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in get_bool v in
return (e_bool b Environment.empty) return (e_bool b)
) )
| t when (compare t (t_bool ()).type_content) = 0-> ( | t when (compare t (t_bool ()).type_content) = 0-> (
let%bind b = let%bind b =
trace_strong (wrong_mini_c_value "bool" v) @@ trace_strong (wrong_mini_c_value "bool" v) @@
get_bool v in get_bool v in
return (e_bool b Environment.empty) return (e_bool b)
) )
| T_constant type_constant -> ( | T_constant type_constant -> (
match type_constant with 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) @@ trace_strong (wrong_mini_c_value "option" v) @@
get_option v in get_option v in
match opt with match opt with
| None -> ok (e_a_empty_none o) | None -> ok (e_a_none o)
| Some s -> | Some s ->
let%bind s' = untranspile s o in 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}-> ( | TC_map {k=k_ty;v=v_ty}-> (
let%bind map = let%bind map =

51
src/passes/13-self_michelson/self_michelson.ml
View File

@ -422,6 +422,56 @@ let rec opt_combine_drops (x : michelson) : michelson =
Prim (l, p, List.map opt_combine_drops args, annot) Prim (l, p, List.map opt_combine_drops args, annot)
| x -> x | 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 = let optimize : michelson -> michelson =
fun x -> fun x ->
let x = use_lambda_instr x in let x = use_lambda_instr x in
@ -436,4 +486,5 @@ let optimize : michelson -> michelson =
] in ] in
let x = iterate_optimizer (sequence_optimizers optimizers) x in let x = iterate_optimizer (sequence_optimizers optimizers) x in
let x = opt_combine_drops x in let x = opt_combine_drops x in
let x = opt_strip_annots x in
x x

6
src/passes/8-typer-new/PP.ml
View File

@ -2,7 +2,7 @@ open Ast_typed
open Format open Format
module UF = UnionFind.Poly2 module UF = UnionFind.Poly2
let type_constraint_ : _ -> type_constraint_simpl_ -> unit = fun ppf -> let type_constraint_ : _ -> type_constraint_simpl -> unit = fun ppf ->
function function
|SC_Constructor { tv; c_tag; tv_list=_ } -> |SC_Constructor { tv; c_tag; tv_list=_ } ->
let ct = match c_tag with 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_Poly _ -> fprintf ppf "Poly"
|SC_Typeclass _ -> fprintf ppf "TC" |SC_Typeclass _ -> fprintf ppf "TC"
let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf { reason_simpl ; c_simpl } -> let type_constraint : _ -> type_constraint_simpl -> unit = fun ppf c ->
fprintf ppf "%a (reason: %s)" type_constraint_ c_simpl reason_simpl fprintf ppf "%a (reason: %s)" type_constraint_ c (reason_simpl c)
let all_constraints ppf ac = let all_constraints ppf ac =
fprintf ppf "[%a]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";\n") type_constraint) ac fprintf ppf "[%a]" (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";\n") type_constraint) ac

31
src/passes/8-typer-new/README Normal file
View File

@ -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

69
src/passes/8-typer-new/constraint_databases.ml Normal file
View File

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

52
src/passes/8-typer-new/heuristic_break_ctor.ml Normal file
View File

@ -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 *)

53
src/passes/8-typer-new/heuristic_specialize1.ml Normal file
View File

@ -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 *)

126
src/passes/8-typer-new/normalizer.ml Normal file
View File

@ -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]

669
src/passes/8-typer-new/solver.ml
View File

@ -1,623 +1,24 @@
open Trace open Trace
module Core = Typesystem.Core module Core = Typesystem.Core
module Map = RedBlackTrees.PolyMap module Map = RedBlackTrees.PolyMap
module Set = RedBlackTrees.PolySet module Set = RedBlackTrees.PolySet
module UF = UnionFind.Poly2 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 open Ast_typed.Types
open Solver_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.c_simpl 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.c_simpl 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`
<polymorphic types are allowed. *)
let check_applied ((reduced, _new_constraints) as x) =
let () = match reduced with
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
(* 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 (P_variable fresh) a "normalizer: simpl") in
let (dbs , cs2) = normalizer_simpl dbs (c_equation (P_variable fresh) b "normalizer: simpl") 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 (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
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 (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
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
(* 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
(* 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
(* 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
(* 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
(* 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]
(* sub-sub component: lazy selector (don't re-try all selectors every time) (* sub-sub component: lazy selector (don't re-try all selectors every time)
* For now: just re-try everytime *) * 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 a = k(var …) and a = k'(var' …) *)
fun type_constraint_simpl dbs ->
match type_constraint_simpl.c_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
(* produce constraints: *)
(* a.tv = b.tv *)
let eq1 = c_equation (P_variable a.tv) (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 (P_variable aa) (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 :-( :-( :-( :-( (* 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. *) We need to return a lazy stream of constraints. *)
let (<?) ca cb =
if ca = 0 then cb () else ca
let rec compare_list f = function
| hd1::tl1 -> (function
[] -> 1
| hd2::tl2 ->
f hd1 hd2 <? fun () ->
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 = function
| P_forall { binder=a1; constraints=a2; body=a3 } -> (function
| P_forall { binder=b1; constraints=b2; body=b3 } ->
compare_type_variable a1 b1 <? fun () ->
compare_list compare_type_constraint a2 b2 <? fun () ->
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 <? fun () -> 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 <? fun () -> 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 <? fun () -> 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 <? fun () -> 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 <? fun () -> compare_label a2 b2 <? fun () -> 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 <? fun () ->
compare_type_constraint_list a2 b2 <? fun () ->
compare_type_expression a3 b3
let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
compare_type_variable a1 b1 <? fun () ->
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 } =
compare_type_variable a1 b1 <? fun () -> compare_simple_c_constant a2 b2 <? fun () -> 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 <? fun () ->
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 <? fun () -> 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 *)
(* 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
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 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 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
let () = if (a.tv <> b.tv) then failwith "internal error" else () in
(* produce constraints: *)
(* create a fresh existential variable to instantiate the polymorphic type b *)
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 (reduced, new_constraints) = check_applied @@ type_level_eval apply in
let eq1 = c_equation (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 = 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 selector propagator ->
fun already_selected old_type_constraint dbs -> fun already_selected old_type_constraint dbs ->
(* TODO: thread some state to know which selector outputs were already seen *) (* TODO: thread some state to know which selector outputs were already seen *)
match selector old_type_constraint dbs with match selector old_type_constraint dbs with
WasSelected selected_outputs -> WasSelected selected_outputs ->
(* TODO: fold instead. *) let Set.{ set = already_selected ; duplicates = _ ; added = selected_outputs } = Set.add_list selected_outputs already_selected in
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 *) (* Call the propagation rule *)
let new_contraints_and_assignments = List.map (fun s -> propagator s dbs) selected_outputs in 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 let (new_constraints , new_assignments) = List.split new_contraints_and_assignments in
@ -626,8 +27,9 @@ let propagator_specialize1 : output_specialize1 propagator =
| WasNotSelected -> | WasNotSelected ->
(already_selected, [] , []) (already_selected, [] , [])
let select_and_propagate_break_ctor = select_and_propagate selector_break_ctor propagator_break_ctor (* TODO: put the heuristics with their state in a list. *)
let select_and_propagate_specialize1 = select_and_propagate selector_specialize1 propagator_specialize1 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. (* Takes a constraint, applies all selector+propagator pairs to it.
Keeps track of which constraints have already been selected. *) Keeps track of which constraints have already been selected. *)
@ -660,7 +62,7 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
match new_constraints with match new_constraints with
| [] -> (already_selected, dbs) | [] -> (already_selected, dbs)
| new_constraint :: tl -> | 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) = let (already_selected , new_constraints' , dbs) =
List.fold_left List.fold_left
(fun (already_selected , nc , dbs) c -> (fun (already_selected , nc , dbs) c ->
@ -675,40 +77,20 @@ let rec select_and_propagate_all : _ -> type_constraint selector_input list -> s
(* constraint propagation: (buch of constraints) → (new constraints * assignments) *) (* constraint propagation: (buch of constraints) → (new constraints * assignments) *)
(* Below is a draft *) (* Below is a draft *)
(* type state = { let initial_state : typer_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 = structured_dbs =
{ {
all_constraints = [] ; (* type_constraint_simpl list *) all_constraints = ([] : type_constraint_simpl list) ;
aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare ; (* unionfind *) aliases = UF.empty (fun s -> Format.asprintf "%a" Var.pp s) Var.compare;
assignments = Map.create ~cmp:Var.compare; (* c_constructor_simpl TypeVariableMap.t *) assignments = (Map.create ~cmp:Var.compare : (type_variable, c_constructor_simpl) Map.t);
grouped_by_variable = Map.create ~cmp:Var.compare; (* constraints TypeVariableMap.t *) grouped_by_variable = (Map.create ~cmp:Var.compare : (type_variable, constraints) Map.t);
cycle_detection_toposort = (); (* unit *) cycle_detection_toposort = ();
} ; } ;
already_selected = { already_selected = {
break_ctor = Set.create ~cmp:compare_output_break_ctor; break_ctor = Set.create ~cmp:Solver_should_be_generated.compare_output_break_ctor;
specialize1 = Set.create ~cmp:compare_output_specialize1 ; specialize1 = Set.create ~cmp:Solver_should_be_generated.compare_output_specialize1 ;
} }
} }
@ -721,23 +103,6 @@ let initial_state : typer_state = (* {
state any further. Suzanne *) state any further. Suzanne *)
let discard_state (_ : typer_state) = () 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 *) (* This is the solver *)
let aggregate_constraints : typer_state -> type_constraint list -> typer_state result = fun state newc -> let aggregate_constraints : typer_state -> type_constraint list -> typer_state result = fun state newc ->
(* TODO: Iterate over constraints *) (* TODO: Iterate over constraints *)
@ -747,12 +112,6 @@ let aggregate_constraints : typer_state -> type_constraint list -> typer_state r
(*let { constraints ; eqv } = state in (*let { constraints ; eqv } = state in
ok { constraints = constraints @ newc ; eqv }*) ok { constraints = constraints @ newc ; eqv }*)
(* Later on, we'll ensure that all the heuristics register the (* Later on, we'll ensure that all the heuristics register the
existential/unification variables that they create, as well as the existential/unification variables that they create, as well as the
new constraints that they create. We will then check that they only new constraints that they create. We will then check that they only

214
src/passes/8-typer-new/solver_should_be_generated.ml Normal file
View File

@ -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 (<?) ca cb =
if ca = 0 then cb () else ca
let rec compare_list f = function
| hd1::tl1 -> (function
[] -> 1
| hd2::tl2 ->
f hd1 hd2 <? fun () ->
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 <? fun () ->
compare_list compare_type_constraint a2 b2 <? fun () ->
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 <? fun () -> 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 <? fun () -> 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 <? fun () -> 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 <? fun () -> 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 <? fun () -> compare_label a2 b2 <? fun () -> 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 <? fun () ->
compare_type_constraint_list a2 b2 <? fun () ->
compare_type_expression a3 b3
let compare_c_poly_simpl { tv = a1; forall = a2 } { tv = b1; forall = b2 } =
compare_type_variable a1 b1 <? fun () ->
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 <? fun () -> compare_simple_c_constant a2 b2 <? fun () -> 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 <? fun () ->
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 <? fun () -> 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

18
src/passes/8-typer-new/solver_types.ml Normal file
View File

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

18
src/passes/8-typer-new/typelang.ml Normal file
View File

@ -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`
<polymorphic types are allowed. *)
let check_applied ((reduced, _new_constraints) as x) =
let () = match reduced with
{ 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

9
src/passes/8-typer-new/typer.ml
View File

@ -29,7 +29,7 @@ let rec type_declaration env state : I.declaration -> (environment * O.typer_sta
trace (constant_declaration_error binder expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression env state expression in type_expression env state expression in
let post_env = Environment.add_ez_declaration binder expr env 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 = 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%bind new_state = aggregate_constraints state constraints in
let tv = t_variable type_name () in let tv = t_variable type_name () in
let location = ae.location 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 ok @@ (expr' , new_state) in
let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in let return_wrapped expr state (constraints , expr_type) = return expr state constraints expr_type in
let main_error = let main_error =
@ -416,12 +416,11 @@ and type_lambda e state {
let%bind input_type' = bind_map_option (evaluate_type e) input_type in 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%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 e' = Environment.add_ez_binder (binder) fresh e in
let%bind (result , state') = type_expression e' state result 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 = Wrap.lambda fresh input_type' output_type' result.type_expression in
let wrapped = Solver.Wrap.lambda fresh input_type' output_type' in
ok (({binder;result}:O.lambda),state',wrapped) 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 = and type_constant (name:I.constant') (lst:O.type_expression list) (tv_opt:O.type_expression option) : (O.constant' * O.type_expression) result =

80
src/passes/8-typer-new/wrap.ml
View File

@ -44,7 +44,7 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
p_constant C_arrow (List.map type_expression_to_type_value [ 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) -> | T_constant (type_name) ->
let csttag = T.(match type_name with let csttag = T.(match type_name with
| TC_unit -> C_unit | 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) p_constant C_record (List.map type_expression_to_type_value_copypasted tlist)
| T_arrow {type1;type2} -> | T_arrow {type1;type2} ->
p_constant C_arrow (List.map type_expression_to_type_value_copypasted [ 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) -> | T_constant (type_name) ->
let csttag = T.(match type_name with let csttag = T.(match type_name with
| TC_unit -> C_unit | 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 variable : I.expression_variable -> T.type_expression -> (constraints * T.type_variable) = fun _name expr ->
let pattern = type_expression_to_type_value expr in let pattern = type_expression_to_type_value expr in
let type_name = Core.fresh_type_variable () 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 literal : T.type_expression -> (constraints * T.type_variable) = fun t ->
let pattern = type_expression_to_type_value t in let pattern = type_expression_to_type_value t in
let type_name = Core.fresh_type_variable () 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 () -> 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 patterns = List.map type_expression_to_type_value tys in
let pattern = p_constant C_record patterns in let pattern = p_constant C_record patterns in
let type_name = Core.fresh_type_variable () 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_tuple = ('label:int, 'v) … -> record ('label : 'v) … *)
(* let t_constructor = ('label:string, 'v) -> variant ('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 sum = type_expression_to_type_value sum in
let whole_expr = Core.fresh_type_variable () 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" ; c_equation t_arg c_arg "wrap: construcotr: arg" ;
] , whole_expr ] , whole_expr
let record : T.field_content T.label_map -> (constraints * T.type_variable) = fun fields -> 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 record_type = type_expression_to_type_value (T.t_record fields ()) in
let whole_expr = Core.fresh_type_variable () 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) = let collection : O.constant_tag -> T.type_expression list -> (constraints * T.type_variable) =
fun ctor element_tys -> 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 aux elt =
let elt' = type_expression_to_type_value elt let elt' = type_expression_to_type_value elt
in c_equation elttype elt' "wrap: collection: elt" in in c_equation elttype elt' "wrap: collection: elt" in
let equations = List.map aux element_tys in let equations = List.map aux element_tys in
let whole_expr = Core.fresh_type_variable () 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 ] @ equations , whole_expr
let list = collection T.C_list 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) = let map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys -> fun kv_tys ->
let k_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.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 aux_k (k , _v) =
let k' = type_expression_to_type_value k in let k' = type_expression_to_type_value k in
c_equation k_type k' "wrap: map: key" 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 equations_v = List.map aux_v kv_tys in
let whole_expr = Core.fresh_type_variable () 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 ] @ equations_k @ equations_v , whole_expr
let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) = let big_map : (T.type_expression * T.type_expression) list -> (constraints * T.type_variable) =
fun kv_tys -> fun kv_tys ->
let k_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.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 aux_k (k , _v) =
let k' = type_expression_to_type_value k in let k' = type_expression_to_type_value k in
c_equation k_type k' "wrap: big_map: key" 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 (* TODO: this doesn't tag big_maps uniquely (i.e. if two
big_map have the same type, they can be swapped. *) 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 ] @ equations_k @ equations_v , whole_expr
let application : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 f' = type_expression_to_type_value f in
let arg' = type_expression_to_type_value arg 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 ] , whole_expr
let look_up : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 ds' = type_expression_to_type_value ds in
let ind' = type_expression_to_type_value ind in let ind' = type_expression_to_type_value ind in
let whole_expr = Core.fresh_type_variable () 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 ds' (p_constant C_map [ind' ; v]) "wrap: look_up: map" ;
c_equation (P_variable whole_expr) (p_constant C_option [P_variable v]) "wrap: look_up: whole" ; c_equation ({ tsrc = "wrap: look_up: whole" ; t = P_variable whole_expr }) (p_constant C_option [v]) "wrap: look_up: whole" ;
] , whole_expr ] , whole_expr
let sequence : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 let whole_expr = Core.fresh_type_variable () in
[ [
c_equation a' (p_constant C_unit []) "wrap: sequence: first" ; 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 ] , whole_expr
let loop : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 body' = type_expression_to_type_value body in
let whole_expr = Core.fresh_type_variable () 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 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 ] , whole_expr
let let_in : T.type_expression -> T.type_expression option -> T.type_expression -> (constraints * T.type_variable) = 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 | Some annot -> [c_equation rhs' (type_expression_to_type_value annot) "wrap: let_in: rhs"] in
let whole_expr = Core.fresh_type_variable () 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 ] @ rhs_tv_opt', whole_expr
let recursive : T.type_expression -> (constraints * T.type_variable) = 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 fun_type = type_expression_to_type_value fun_type in
let whole_expr = Core.fresh_type_variable () 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 ], whole_expr
let assign : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 let whole_expr = Core.fresh_type_variable () in
[ [
c_equation v' e' "wrap: assign: var type must eq rhs type" ; 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 ] , whole_expr
let annotation : T.type_expression -> T.type_expression -> (constraints * T.type_variable) = 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 let whole_expr = Core.fresh_type_variable () in
[ [
c_equation e' annot' "wrap: annotation: expr type must eq annot" ; 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 ] , whole_expr
let matching : T.type_expression list -> (constraints * T.type_variable) = let matching : T.type_expression list -> (constraints * T.type_variable) =
fun es -> fun es ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let type_expressions = (List.map type_expression_to_type_value es) 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 in cs, whole_expr
let fresh_binder () = let fresh_binder () =
@ -339,24 +339,26 @@ let lambda
: T.type_expression -> : T.type_expression ->
T.type_expression option -> T.type_expression option ->
T.type_expression option -> T.type_expression option ->
T.type_expression ->
(constraints * T.type_variable) = (constraints * T.type_variable) =
fun fresh arg body -> fun fresh arg output result ->
let whole_expr = Core.fresh_type_variable () in let whole_expr = Core.fresh_type_variable () in
let unification_arg = Core.fresh_type_variable () in let unification_arg = T.{ tsrc = "wrap: lambda: arg" ; t = P_variable (Core.fresh_type_variable ()) } in
let unification_body = 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 let arg' = match arg with
None -> [] 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 let output' = match output with
None -> [] None -> []
| Some body -> [c_equation (P_variable 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 [ in [
c_equation (type_expression_to_type_value fresh) (P_variable unification_arg) "wrap: lambda: arg" ; c_equation unification_output result' "wrap: lambda: result" ;
c_equation (P_variable whole_expr) c_equation (type_expression_to_type_value fresh) unification_arg "wrap: lambda: arg" ;
(p_constant C_arrow ([P_variable unification_arg ; c_equation ({ tsrc = "wrap: lambda: whole" ; t = P_variable whole_expr })
P_variable unification_body])) (p_constant C_arrow ([unification_arg ; unification_output]))
"wrap: lambda: arrow (whole)" "wrap: lambda: arrow (whole)"
] @ arg' @ body' , whole_expr ] @ arg' @ output' , whole_expr
(* This is pretty much a wrapper for an n-ary function. *) (* This is pretty much a wrapper for an n-ary function. *)
let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) = let constant : O.type_value -> T.type_expression list -> (constraints * T.type_variable) =
@ -365,5 +367,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' = List.map type_expression_to_type_value args in
let args_tuple = p_constant C_record 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 ] , whole_expr

25
src/passes/8-typer-old/typer.ml
View File

@ -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%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 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 let (e', _placeholder_for_state_of_new_typer , d') = Location.unwrap ed' in
match d' with ok (e', loc ed' d' :: acc)
| None -> ok (e', acc)
| Some d' -> ok (e', loc ed' d' :: acc)
in in
let%bind (_, lst) = let%bind (_, lst) =
trace (fun () -> program_error p ()) @@ trace (fun () -> program_error p ()) @@
bind_fold_list aux (DEnv.default, []) p in bind_fold_list aux (DEnv.default, []) p in
ok @@ (List.rev lst , (Solver.placeholder_for_state_of_new_typer ())) 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_name , type_expression) -> | Declaration_type (type_binder , type_expr) ->
let%bind tv = evaluate_type env type_expression in let%bind tv = evaluate_type env type_expr in
let env' = Environment.add_type (type_name) tv env in let env' = Environment.add_type (type_binder) tv env in
ok (env', (Solver.placeholder_for_state_of_new_typer ()) , None) ok (env', (Solver.placeholder_for_state_of_new_typer ()) , (O.Declaration_type { type_binder ; type_expr = tv } ))
| Declaration_constant (binder , tv_opt , inline, expression) -> ( | Declaration_constant (binder , tv_opt , inline, expression) -> (
let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in let%bind tv'_opt = bind_map_option (evaluate_type env) tv_opt in
let%bind expr = let%bind expr =
trace (constant_declaration_error binder expression tv'_opt) @@ trace (constant_declaration_error binder expression tv'_opt) @@
type_expression' ?tv_opt:tv'_opt env expression in type_expression' ?tv_opt:tv'_opt env expression in
let post_env = Environment.add_ez_declaration binder expr env 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 ()) , (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 = 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 +672,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression
= fun e _placeholder_for_state_of_new_typer ?tv_opt ae -> = fun e _placeholder_for_state_of_new_typer ?tv_opt ae ->
let%bind res = type_expression' e ?tv_opt ae in let%bind res = type_expression' e ?tv_opt ae in
ok (res, (Solver.placeholder_for_state_of_new_typer ())) 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 -> 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 module L = Logger.Stateful() in
let return expr tv = let return expr tv =
@ -682,7 +681,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
| None -> ok () | None -> ok ()
| Some tv' -> O.assert_type_expression_eq (tv' , tv) in | Some tv' -> O.assert_type_expression_eq (tv' , tv) in
let location = ae.location 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 main_error =
let title () = "typing expression" in let title () = "typing expression" in
let content () = "" in let content () = "" in
@ -736,7 +735,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
generic_try (bad_record_access property ae prev.type_expression ae.location) 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 @@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in
let location = ae.location 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 in
let%bind ae = let%bind ae =
trace (simple_info "accessing") @@ aux e' path in trace (simple_info "accessing") @@ aux e' path in
@ -832,7 +831,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in 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%bind body = type_expression' ?tv_opt:(Some tv_out) e' result in
let output_type = body.type_expression 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 lst' = [lambda'; v_col; v_initr] in
let tv_lst = List.map get_type_expression lst' in let tv_lst = List.map get_type_expression lst' in
let%bind (opname', tv) = let%bind (opname', tv) =
@ -853,7 +852,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression
let e' = Environment.add_ez_binder lname input_type e in let e' = Environment.add_ez_binder lname input_type e in
let%bind body = type_expression' e' result in let%bind body = type_expression' e' result in
let output_type = body.type_expression 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 lst' = [lambda';v_initr] in
let tv_lst = List.map get_type_expression lst' in let tv_lst = List.map get_type_expression lst' in
let%bind (opname',tv) = type_constant opname tv_lst tv_opt in let%bind (opname',tv) = type_constant opname tv_lst tv_opt in

2
src/passes/8-typer-old/typer.mli
View File

@ -39,7 +39,7 @@ module Errors : sig
end end
val type_program : I.program -> (O.program * O.typer_state) result 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 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 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 val type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O.typer_state) result

36
src/passes/9-self_ast_typed/helpers.ml
View File

@ -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 -> and map_program : mapper -> program -> program result = fun m p ->
let aux = fun (x : declaration) -> let aux = fun (x : declaration) ->
match x with match x with
| Declaration_constant {binder; expr ; inline ; post_env} -> ( | Declaration_constant {binder; expr ; inline} -> (
let%bind expr = map_expression m expr in 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 in
bind_map_list (bind_map_location aux) p 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 -> 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) -> let aux = fun (acc,acc_prg) (x : declaration Location.wrap) ->
match Location.unwrap x with 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%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}]) 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 in
bind_fold_list aux (init,[]) p bind_fold_list aux (init,[]) p
@ -298,16 +303,19 @@ type contract_type = {
} }
let fetch_contract_type : string -> program -> contract_type result = fun main_fname program -> let fetch_contract_type : string -> program -> contract_type result = fun main_fname program ->
let main_decl = List.rev @@ List.filter let aux declt = match Location.unwrap declt with
(fun declt -> | Declaration_constant ({ binder ; expr=_ ; inline=_ } as p) ->
let (Declaration_constant { binder ; expr=_ ; inline=_ ; post_env=_ }) = Location.unwrap declt in if String.equal (Var.to_name binder) main_fname
String.equal (Var.to_name binder) main_fname then Some p
) else None
program | Declaration_type _ -> None
in in
match main_decl with let main_decl_opt = List.find_map aux @@ List.rev program in
| (hd::_) -> ( let%bind main_decl =
let (Declaration_constant { binder=_ ; expr ; inline=_ ; post_env=_ }) = Location.unwrap hd in 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 match expr.type_expression.type_content with
| T_arrow {type1 ; type2} -> ( | T_arrow {type1 ; type2} -> (
match type1.type_content , type2.type_content with match type1.type_content , type2.type_content with
@ -323,5 +331,3 @@ let fetch_contract_type : string -> program -> contract_type result = fun main_f
| _ -> fail @@ Errors.bad_contract_io main_fname expr | _ -> fail @@ Errors.bad_contract_io main_fname expr
) )
| _ -> fail @@ Errors.bad_contract_io main_fname expr | _ -> fail @@ Errors.bad_contract_io main_fname expr
)
| [] -> simple_fail ("Entrypoint '"^main_fname^"' does not exist")

10
src/passes/9-self_ast_typed/michelson_layout.ml
View File

@ -13,25 +13,25 @@ let accessor (record:expression) (path:label) (t:type_expression) =
{ expression_content = E_record_accessor {record; path} ; { expression_content = E_record_accessor {record; path} ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = record.environment } }
let constructor (constructor:constructor') (element:expression) (t:type_expression) = let constructor (constructor:constructor') (element:expression) (t:type_expression) =
{ expression_content = E_constructor { constructor ; element } ; { expression_content = E_constructor { constructor ; element } ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = element.environment } }
let match_var (t:type_expression) = let match_var (t:type_expression) =
{ expression_content = E_variable (Var.of_name "x") ; { expression_content = E_variable (Var.of_name "x") ;
location = Location.generated ; location = Location.generated ;
type_expression = t ; type_expression = t ;
environment = Environment.add_ez_binder (Var.of_name "x") t Environment.empty} }
let matching (e:expression) matchee cases = let matching (e:expression) matchee cases =
{ expression_content = E_matching {matchee ; cases}; { expression_content = E_matching {matchee ; cases};
location = Location.generated ; location = Location.generated ;
type_expression = e.type_expression ; type_expression = e.type_expression ;
environment = e.environment } }
let rec descend_types s lmap i = let rec descend_types s lmap i =
if i > 0 then 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 } ; let exp = { expression_content = E_record_accessor {record = prev ; path = label } ;
location = Location.generated ; location = Location.generated ;
type_expression = field_type ; type_expression = field_type ;
environment = prev.environment } in } in
let conv_map' = LMap.add (Label "0") exp conv_map 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' LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map'

3
src/passes/9-self_ast_typed/self_ast_typed.ml
View File

@ -13,8 +13,7 @@ let contract_passes = [
let all_program program = let all_program program =
let all_p = List.map Helpers.map_program all_passes in let all_p = List.map Helpers.map_program all_passes in
let%bind program' = bind_chain all_p program in let%bind program' = bind_chain all_p program in
let program'' = Recompute_environment.program Environment.default program' in ok program'
ok program''
let all_expression = let all_expression =
let all_p = List.map Helpers.map_expression all_passes in let all_p = List.map Helpers.map_expression all_passes in

22
src/passes/operators/operators.ml
View File

@ -434,17 +434,17 @@ module Typer = struct
module Operators_types = struct module Operators_types = struct
open Typesystem.Shorthands open Typesystem.Shorthands
let tc_subarg a b c = tc [a;b;c] [ (*TODO…*) ] let tc_subarg a b c = tc "arguments for (-)" [a;b;c] [ (*TODO…*) ]
let tc_sizearg a = tc [a] [ [int] ] let tc_sizearg a = tc "arguments for size" [a] [ [int] ]
let tc_packable a = tc [a] [ [int] ; [string] ; [bool] (*TODO…*) ] let tc_packable a = tc "packable" [a] [ [int] ; [string] ; [bool] (*TODO…*) ]
let tc_timargs a b c = tc [a;b;c] [ [nat;nat;nat] ; [int;int;int] (*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 [a;b;c] [ (*TODO…*) ] let tc_edivargs a b c = tc "arguments for ediv" [a;b;c] [ (*TODO…*) ]
let tc_divargs a b c = tc [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 [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 [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 [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ] let tc_comparable a = tc "comparable" [a] [ [nat] ; [int] ; [mutez] ; [timestamp] ]
let tc_concatable a = tc [a] [ [string] ; [bytes] ] let tc_concatable a = tc "concatenable" [a] [ [string] ; [bytes] ]
let tc_storable a = tc [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ] let tc_storable a = tc "storable" [a] [ [string] ; [bytes] ; (*Humm .. TODO ?*) ]
let t_none = forall "a" @@ fun a -> option a let t_none = forall "a" @@ fun a -> option a

1
src/stages/1-ast_imperative/ast_imperative.ml
View File

@ -3,6 +3,5 @@ include Types
(* include Misc *) (* include Misc *)
include Combinators include Combinators
module Types = Types module Types = Types
module Misc = Misc
module PP=PP module PP=PP
module Combinators = Combinators module Combinators = Combinators

353
src/stages/1-ast_imperative/misc.ml
View File

@ -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@[<v>- %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 *)

20
src/stages/1-ast_imperative/misc.mli
View File

@ -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

1
src/stages/2-ast_sugar/ast_sugar.ml
View File

@ -3,6 +3,5 @@ include Types
(* include Misc *) (* include Misc *)
include Combinators include Combinators
module Types = Types module Types = Types
module Misc = Misc
module PP=PP module PP=PP
module Combinators = Combinators module Combinators = Combinators

350
src/stages/2-ast_sugar/misc.ml
View File

@ -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@[<v>- %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 *)

20
src/stages/2-ast_sugar/misc.mli
View File

@ -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

4
src/stages/4-ast_typed/PP.ml
View File

@ -326,8 +326,10 @@ and matching : (formatter -> expression -> unit) -> _ -> matching_expr -> unit =
let declaration ppf (d : declaration) = let declaration ppf (d : declaration) =
match d with 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 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) = let program ppf (p : program) =
fprintf ppf "@[<v>%a@]" fprintf ppf "@[<v>%a@]"

43
src/stages/4-ast_typed/ast.ml
View File

@ -272,31 +272,30 @@ and declaration_loc = declaration location_wrap
and program = declaration_loc list and program = declaration_loc list
and declaration_constant = {
binder : expression_variable ;
expr : expression ;
inline : bool ;
post_env : environment ;
}
and declaration =
(* A Declaration_constant is described by (* A Declaration_constant is described by
* a name + a type-annotated expression * a name + a type-annotated expression
* a boolean indicating whether it should be inlined * a boolean indicating whether it should be inlined
* the environment before the declaration (the original environment) * the environment before the declaration (the original environment)
* the environment after the declaration (i.e. with that new declaration added to 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 ;
}
and declaration_type = {
type_binder : type_variable ;
type_expr : type_expression ;
}
and declaration =
| Declaration_constant of declaration_constant | Declaration_constant of declaration_constant
(* | Declaration_type of declaration_type
| Declaration_type of (type_variable * type_expression)
| Declaration_constant of (named_expression * (environment * environment))
*)
(* | Macro_declaration of macro_declaration *)
and expression = { and expression = {
expression_content: expression_content ; expression_content: expression_content ;
location: location ; location: location ;
type_expression: type_expression ; type_expression: type_expression ;
environment: environment ;
} }
and map_kv = { and map_kv = {
@ -464,11 +463,15 @@ type constant_tag =
| C_chain_id (* * *) | C_chain_id (* * *)
(* TODO: rename to type_expression or something similar (it includes variables, and unevaluated functions + applications *) (* 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_forall of p_forall
| P_variable of type_variable | P_variable of type_variable
| P_constant of p_constant | P_constant of p_constant
| P_apply of p_apply | P_apply of p_apply
and type_value = {
tsrc : string;
t : type_value_ ;
}
and p_apply = { and p_apply = {
tf : type_value ; tf : type_value ;
@ -557,6 +560,7 @@ and constraints = {
} }
and type_variable_list = type_variable list and type_variable_list = type_variable list
and c_constructor_simpl = { and c_constructor_simpl = {
reason_constr_simpl : string ;
tv : type_variable; tv : type_variable;
c_tag : constant_tag; c_tag : constant_tag;
tv_list : type_variable_list; tv_list : type_variable_list;
@ -570,24 +574,23 @@ and c_equation_e = {
bex : type_expression ; bex : type_expression ;
} }
and c_typeclass_simpl = { and c_typeclass_simpl = {
reason_typeclass_simpl : string ;
tc : typeclass ; tc : typeclass ;
args : type_variable_list ; args : type_variable_list ;
} }
and c_poly_simpl = { and c_poly_simpl = {
reason_poly_simpl : string ;
tv : type_variable ; tv : type_variable ;
forall : p_forall ; forall : p_forall ;
} }
and type_constraint_simpl = { and type_constraint_simpl =
reason_simpl : string ;
c_simpl : type_constraint_simpl_ ;
}
and type_constraint_simpl_ =
| SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *) | SC_Constructor of c_constructor_simpl (* α = ctor(β, …) *)
| SC_Alias of c_alias (* α = β *) | SC_Alias of c_alias (* α = β *)
| SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *) | SC_Poly of c_poly_simpl (* α = forall β, δ where δ can be a more complex type *)
| SC_Typeclass of c_typeclass_simpl (* TC(α, …) *) | SC_Typeclass of c_typeclass_simpl (* TC(α, …) *)
and c_alias = { and c_alias = {
reason_alias_simpl : string ;
a : type_variable ; a : type_variable ;
b : type_variable ; b : type_variable ;
} }

4
src/stages/4-ast_typed/ast_typed.ml
View File

@ -2,9 +2,9 @@ module Types = Types
module Environment = Environment module Environment = Environment
module PP = PP module PP = PP
module PP_generic = PP_generic module PP_generic = PP_generic
module Compare_generic = Compare_generic
module Combinators = struct module Combinators = struct
include Combinators include Combinators
include Combinators_environment
end end
module Misc = struct module Misc = struct
include Misc include Misc
@ -15,3 +15,5 @@ module Helpers = Helpers
include Types include Types
include Misc include Misc
include Combinators include Combinators
let program_environment env program = fst (Compute_environment.program env program)

11
src/stages/4-ast_typed/combinators.ml
View File

@ -24,10 +24,9 @@ module Errors = struct
end end
let make_t ?(loc = Location.generated) type_content core = {type_content; location=loc; type_meta = core} 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 ; expression_content ;
type_expression ; type_expression ;
environment ;
location ; location ;
} }
let make_n_t type_name type_value = { type_name ; type_value } 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_expression (x:expression) = x.type_expression
let get_type' (x:type_expression) = x.type_content 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_expression (x:expression) = x.expression_content
let get_lambda e : _ result = match e.expression_content with 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_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_unit = make_e (e_unit ()) (t_unit ())
let e_a_int n = make_e (e_int n) (t_int ()) 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_nat n = make_e (e_nat n) (t_nat ())
let e_a_mutez n = make_e (e_mutez n) (t_mutez ()) 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_string s = make_e (e_string s) (t_string ())
let e_a_address s = make_e (e_address s) (t_address ()) let e_a_address s = make_e (e_address s) (t_address ())
let e_a_pair a b = make_e (e_pair a b) 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 get_declaration_by_name : program -> string -> declaration result = fun p name ->
let aux : declaration -> bool = fun declaration -> let aux : declaration -> bool = fun declaration ->
match declaration with 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 in
trace_option (Errors.declaration_not_found name ()) @@ trace_option (Errors.declaration_not_found name ()) @@
List.find_opt aux @@ List.map Location.unwrap p List.find_opt aux @@ List.map Location.unwrap p

37
src/stages/4-ast_typed/combinators.mli
View File

@ -3,7 +3,7 @@ open Types
val make_n_t : type_variable -> type_expression -> named_type_content 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_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_bool : ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression
val t_string : ?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 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_expression : expression -> type_expression
val get_type' : type_expression -> type_content val get_type' : type_expression -> type_content
val get_environment : expression -> environment
val get_expression : expression -> expression_content val get_expression : expression -> expression_content
val get_lambda : expression -> lambda result val get_lambda : expression -> lambda result
val get_lambda_with_type : expression -> (lambda * ( type_expression * type_expression) ) 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_int : Z.t -> expression_content
val e_nat : Z.t -> expression_content val e_nat : Z.t -> expression_content
val e_mutez : 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_string : ligo_string -> expression_content
val e_bytes : bytes -> expression_content val e_bytes : bytes -> expression_content
val e_timestamp : Z.t -> 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_variable : expression_variable -> expression_content
val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content val e_let_in : expression_variable -> inline -> expression -> expression -> expression_content
val e_a_unit : environment -> expression val e_a_unit : expression
val e_a_int : Z.t -> environment -> expression val e_a_int : Z.t -> expression
val e_a_nat : Z.t -> environment -> expression val e_a_nat : Z.t -> expression
val e_a_mutez : Z.t -> environment -> expression val e_a_mutez : Z.t -> expression
val e_a_bool : bool -> environment -> expression val e_a_bool : bool -> expression
val e_a_string : ligo_string -> environment -> expression val e_a_string : ligo_string -> expression
val e_a_address : string -> environment -> expression val e_a_address : string -> expression
val e_a_pair : expression -> expression -> environment -> expression val e_a_pair : expression -> expression -> expression
val e_a_some : expression -> environment -> expression val e_a_some : expression -> expression
val e_a_lambda : lambda -> type_expression -> type_expression -> environment -> expression val e_a_lambda : lambda -> type_expression -> type_expression -> expression
val e_a_none : type_expression -> environment -> expression val e_a_none : type_expression -> expression
val e_a_record : expression label_map -> environment -> expression val e_a_record : expression label_map -> expression
val e_a_application : expression -> expression -> environment -> expression val e_a_application : expression -> expression -> expression
val e_a_variable : expression_variable -> type_expression -> environment -> expression val e_a_variable : expression_variable -> type_expression -> expression
val ez_e_a_record : ( label * expression ) list -> environment -> expression val ez_e_a_record : ( label * expression ) list -> expression
val e_a_let_in : expression_variable -> bool -> expression -> expression -> environment -> expression val e_a_let_in : expression_variable -> bool -> expression -> expression -> expression
val get_a_int : expression -> Z.t result val get_a_int : expression -> Z.t result
val get_a_unit : expression -> unit result val get_a_unit : expression -> unit result

25
src/stages/4-ast_typed/combinators_environment.ml
View File

@ -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

19
src/stages/4-ast_typed/combinators_environment.mli
View File

@ -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

43
src/passes/9-self_ast_typed/recompute_environment.ml → src/stages/4-ast_typed/compute_environment.ml
View File

@ -1,23 +1,9 @@
open Ast_typed open Types
(*
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.
*)
let rec expression : environment -> expression -> expression = fun env expr -> let rec expression : environment -> expression -> expression = fun env expr ->
(* Standard helper functions to help with the fold *) (* Standard helper functions to help with the fold *)
let return ?(env' = env) content = { let return content = {
expr with expr with
environment = env' ;
expression_content = content ; expression_content = content ;
} in } in
let return_id = return expr.expression_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 match_cons =
let mc = c.match_cons in let mc = c.match_cons in
let env_hd = Environment.add_ez_binder mc.hd mc.tv env 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 let body = self ~env':env_tl mc.body in
{ mc with body } { mc with body }
in in
@ -139,24 +125,27 @@ and cases : environment -> matching_expr -> matching_expr = fun env cs ->
return @@ Match_variant { c with cases } 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 BAD
We take the old type environment and add it to the current value environment 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. 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 aux (pre_env , rev_decls) decl_wrapped =
let (Declaration_constant c) = Location.unwrap decl_wrapped in match Location.unwrap decl_wrapped with
| Declaration_constant c -> (
let expr = expression pre_env c.expr 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 = 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 } in
let wrap_content = Declaration_constant { c with expr ; post_env = post_env' } in
let decl_wrapped' = { decl_wrapped with wrap_content } in let decl_wrapped' = { decl_wrapped with wrap_content } in
(post_env , decl_wrapped' :: rev_decls) (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 in
let (_last_env , rev_decls) = List.fold_left aux (init_env , []) prog in let (last_env , rev_decls) = List.fold_left aux (init_env , []) prog in
List.rev rev_decls (last_env , List.rev rev_decls)

3
src/stages/4-ast_typed/environment.ml
View File

@ -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 -> let add_ez_declaration : expression_variable -> expression -> t -> t = fun k ae e ->
add_expr k (make_element_declaration e 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 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 *) let get_constructor : Ast_core.constructor' -> t -> (type_expression * type_expression) option = fun k x -> (* Left is the constructor, right is the sum type *)

1
src/stages/4-ast_typed/environment.mli
View File

@ -11,6 +11,7 @@ val get_opt : expression_variable -> t -> element option
val get_type_opt : type_variable -> t -> type_expression option val get_type_opt : type_variable -> t -> type_expression option
val get_constructor : Ast_core.constructor' -> t -> (type_expression * 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 module PP : sig
open Format open Format

23
src/stages/4-ast_typed/misc.ml
View File

@ -512,27 +512,34 @@ let merge_annotation (a:type_expression option) (b:type_expression option) err :
let get_entry (lst : program) (name : string) : expression result = let get_entry (lst : program) (name : string) : expression result =
trace_option (Errors.missing_entry_point name) @@ trace_option (Errors.missing_entry_point name) @@
let aux x = let aux x =
let (Declaration_constant { binder ; expr ; inline=_ ; _ }) = Location.unwrap x in match Location.unwrap x with
| Declaration_constant { binder ; expr ; inline=_ } -> (
if Var.equal binder (Var.of_name name) if Var.equal binder (Var.of_name name)
then Some expr then Some expr
else None else None
)
| Declaration_type _ -> None
in in
List.find_map aux lst 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 = let equal_variables a b : bool =
match a.expression_content, b.expression_content with match a.expression_content, b.expression_content with
| E_variable a, E_variable b -> Var.equal a b | E_variable a, E_variable b -> Var.equal a b
| _, _ -> false | _, _ -> false
let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = let p_constant (p_ctor_tag : constant_tag) (p_ctor_args : p_ctor_args) = {
P_constant { tsrc = "misc.ml/p_constant" ;
t = P_constant {
p_ctor_tag : constant_tag ; p_ctor_tag : constant_tag ;
p_ctor_args : p_ctor_args ; p_ctor_args : p_ctor_args ;
} }
}
let c_equation aval bval reason = { c = C_equation { aval ; bval }; reason } 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

3
src/stages/4-ast_typed/misc.mli
View File

@ -70,7 +70,8 @@ val assert_literal_eq : ( literal * literal ) -> unit result
*) *)
val get_entry : program -> string -> expression result val get_entry : program -> string -> expression result
val program_environment : program -> environment
val p_constant : constant_tag -> p_ctor_args -> type_value val p_constant : constant_tag -> p_ctor_args -> type_value
val c_equation : type_value -> type_value -> string -> type_constraint val c_equation : type_value -> type_value -> string -> type_constraint
val reason_simpl : type_constraint_simpl -> string

27
src/stages/4-ast_typed/misc_smart.ml
View File

@ -8,8 +8,9 @@ let program_to_main : program -> string -> lambda result = fun p s ->
let%bind (main , input_type , _) = let%bind (main , input_type , _) =
let pred = fun d -> let pred = fun d ->
match d with 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_constant _ -> None
| Declaration_type _ -> None
in in
let%bind main = let%bind main =
trace_option (simple_error "no main with given name") @@ 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 | _ -> simple_fail "program main isn't a function" in
ok (main , input_ty , output_ty) ok (main , input_ty , output_ty)
in 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 binder = Var.of_name "@contract_input" in
let result = let result =
let input_expr = e_a_variable binder input_type 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) env in let main_expr = e_a_variable (Var.of_name s) (get_type_expression main) in
e_a_application main_expr input_expr env in e_a_application main_expr input_expr in
ok { ok {
binder ; binder ;
result ; result ;
@ -46,8 +42,8 @@ module Captured_variables = struct
let of_list : expression_variable list -> bindings = fun x -> x let of_list : expression_variable list -> bindings = fun x -> x
let rec expression : bindings -> expression -> bindings result = fun b e -> let rec expression : bindings -> expression -> bindings result = fun b e ->
expression_content b e.environment e.expression_content expression_content b e.expression_content
and expression_content : bindings -> environment -> expression_content -> bindings result = fun b env ec -> and expression_content : bindings -> expression_content -> bindings result = fun b ec ->
let self = expression b in let self = expression b in
match ec with match ec with
| E_lambda l -> ok @@ Free_variables.lambda empty l | 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 let%bind lst' = bind_map_list self arguments in
ok @@ unions lst' ok @@ unions lst'
| E_variable name -> ( | E_variable name -> (
let%bind env_element = if mem name b then ok empty else ok (singleton name)
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"
) )
| E_application {lamb;args} -> | E_application {lamb;args} ->
let%bind lst' = bind_map_list self [ lamb ; args ] in let%bind lst' = bind_map_list self [ lamb ; args ] in
@ -84,7 +75,7 @@ module Captured_variables = struct
expression b' li.let_result expression b' li.let_result
| E_recursive r -> | E_recursive r ->
let b' = union (singleton r.fun_name) b in 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 } -> 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 f (union (singleton pattern) b) body

1
src/stages/4-ast_typed/types_utils.ml
View File

@ -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 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 let%bind (state , m) = PolySet.fold_inc aux s ~init:(ok (state, PolySet.create ~cmp:new_compare)) in
ok (state , m) ok (state , m)

42
src/stages/typesystem/misc.ml
View File

@ -29,7 +29,6 @@ module Substitution = struct
ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env ok @@ T.{expr_var=variable ; env_elt={ type_value; source_environment; definition }}) env
and s_type_environment : T.type_environment w = fun ~substs tenv -> and s_type_environment : T.type_environment w = fun ~substs tenv ->
bind_map_list (fun T.{type_variable ; type_} -> 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 let%bind type_ = s_type_expression ~substs type_ in
ok @@ T.{type_variable ; type_}) tenv ok @@ T.{type_variable ; type_}) tenv
and s_environment : T.environment w = fun ~substs T.{expression_environment ; type_environment} -> and s_environment : T.environment w = fun ~substs T.{expression_environment ; type_environment} ->
@ -45,14 +44,6 @@ module Substitution = struct
let () = ignore @@ substs in let () = ignore @@ substs in
ok var 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 -> and s_label : T.label w = fun ~substs l ->
let () = ignore @@ substs in let () = ignore @@ substs in
ok l ok l
@ -71,7 +62,12 @@ module Substitution = struct
ok @@ type_name ok @@ type_name
and s_type_content : T.type_content w = fun ~substs -> function 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_record _ -> failwith "TODO: T_record"
| T.T_constant type_name -> | T.T_constant type_name ->
let%bind type_name = s_type_name_constant ~substs type_name in let%bind type_name = s_type_name_constant ~substs type_name in
@ -195,20 +191,19 @@ module Substitution = struct
let%bind cases = s_matching_expr ~substs cases in let%bind cases = s_matching_expr ~substs cases in
ok @@ T.E_matching {matchee;cases} 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 expression_content = s_expression_content ~substs expression_content in
let%bind type_expr = s_type_expression ~substs type_expression in let%bind type_expr = s_type_expression ~substs type_expression in
let%bind environment = s_environment ~substs environment in
let location = location 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 -> and s_declaration : T.declaration w = fun ~substs ->
function function
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 binder = s_variable ~substs binder in
let%bind expr = s_expression ~substs expr 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}
ok @@ Ast_typed.Declaration_constant {binder; expr; inline; post_env} | Declaration_type t -> ok (Ast_typed.Declaration_type t)
and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d -> and s_declaration_wrap :T.declaration Location.wrap w = fun ~substs d ->
Trace.bind_map_location (s_declaration ~substs) d Trace.bind_map_location (s_declaration ~substs) d
@ -224,24 +219,24 @@ module Substitution = struct
and type_value ~tv ~substs = and type_value ~tv ~substs =
let self tv = type_value ~tv ~substs in let self tv = type_value ~tv ~substs in
let (v, expr) = 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 v' when Var.equal v' v -> expr
| P_variable _ -> tv | P_variable _ -> tv
| P_constant {p_ctor_tag=x ; p_ctor_args=lst} -> ( | P_constant {p_ctor_tag=x ; p_ctor_args=lst} -> (
let lst' = List.map self lst in 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; targ } -> (
P_apply { tf = self tf ; targ = self targ } { tsrc = "?TODO2?" ; t = P_apply { tf = self tf ; targ = self targ } }
) )
| P_forall p -> ( | P_forall p -> (
let aux c = constraint_ ~c ~substs in let aux c = constraint_ ~c ~substs in
let constraints = List.map aux p.constraints in let constraints = List.map aux p.constraints in
if (p.binder = v) then ( if (p.binder = v) then (
P_forall { p with constraints } { tsrc = "?TODO3?" ; t = P_forall { p with constraints } }
) else ( ) else (
let body = self p.body in let body = self p.body in
P_forall { p with constraints ; body } { tsrc = "?TODO4?" ; t = P_forall { p with constraints ; body } }
) )
) )
@ -271,9 +266,10 @@ module Substitution = struct
(* Performs beta-reduction at the root of the type *) (* Performs beta-reduction at the root of the type *)
let eval_beta_root ~(tv : type_value) = let eval_beta_root ~(tv : type_value) =
match tv with match tv.t with
P_apply {tf = P_forall { binder; constraints; body }; targ} -> 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 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) (type_value ~tv:body ~substs:(mk_substs ~v:binder ~expr:targ) , constraints)
| _ -> (tv , []) | _ -> (tv , [])
end end

17
src/stages/typesystem/shorthands.ml
View File

@ -2,19 +2,24 @@ open Ast_typed.Types
open Core open Core
open Ast_typed.Misc open Ast_typed.Misc
let tc type_vars allowed_list : type_constraint = let tc description type_vars allowed_list : type_constraint = {
{ c = C_typeclass {tc_args = type_vars ; typeclass = allowed_list} ; reason = "shorthands: typeclass" } c = C_typeclass {tc_args = type_vars ;typeclass = allowed_list} ;
reason = "typeclass for operator: " ^ description
}
let forall binder f = let forall binder f =
let () = ignore binder in let () = ignore binder in
let freshvar = fresh_type_variable () 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 forall_tc binder f =
let () = ignore binder in let () = ignore binder in
let freshvar = fresh_type_variable () in let freshvar = fresh_type_variable () in
let (tc, ty) = f (P_variable freshvar) in let (tc, ty) = f { tsrc = "shorthands.ml/forall_tc" ; t = P_variable freshvar } in
P_forall { binder = freshvar ; constraints = tc ; body = ty } { tsrc = "shorthands.ml/forall_tc" ;
t = P_forall { binder = freshvar ; constraints = tc ; body = ty } }
(* chained forall *) (* chained forall *)
let forall2 a b f = 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 unit = p_constant C_unit []
let list t = p_constant C_list [t] let list t = p_constant C_list [t]
let set t = p_constant C_set [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 string = p_constant C_string []
let nat = p_constant C_nat [] let nat = p_constant C_nat []
let mutez = p_constant C_mutez [] let mutez = p_constant C_mutez []

8
src/test/coase_tests.ml
View File

@ -13,13 +13,13 @@ let get_program =
| Some s -> ok s | Some s -> ok s
| None -> ( | None -> (
let%bind (program , state) = type_file "./contracts/coase.ligo" in let%bind (program , state) = type_file "./contracts/coase.ligo" in
let () = Typer.Solver.discard_state state in s := Some (program , state) ;
s := Some program ; ok (program , state)
ok program
) )
let compile_main () = let compile_main () =
let%bind typed_prg = get_program () 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 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 michelson_prg = Ligo.Compile.Of_mini_c.aggregate_and_compile_contract mini_c_prg "main" in
let%bind (_contract: Tezos_utils.Michelson.michelson) = let%bind (_contract: Tezos_utils.Michelson.michelson) =

159
src/test/contracts/id.ligo Normal file
View File

@ -0,0 +1,159 @@
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)), storage with record [
identities = identities;
next_id = new_id + 1;
])
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;
if sender = id_details.owner
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)), storage with record [ identities = identities; ])
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;
if (sender = id_details.controller) or (sender = id_details.owner)
then skip;
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)), 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
begin
if amount = storage.skip_price
then skip
else failwith("Incorrect amount paid.");
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
| 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;

133
src/test/contracts/id.mligo
View File

@ -6,9 +6,21 @@ type id_details = {
profile: bytes profile: bytes
} }
type buy = bytes * address option type buy = {
type update_owner = id * address profile: bytes;
type update_details = id * bytes option * address option 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 = type action =
| Buy of buy | Buy of buy
@ -19,7 +31,14 @@ type action =
(* The prices kept in storage can be changed by bakers, though they (* The prices kept in storage can be changed by bakers, though they
should only be adjusted down over time, not up. *) 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 type return = operation list * storage
@ -38,12 +57,16 @@ a lot that could be eaten up. Should probably do some napkin
calculations for how expensive skipping needs to be to deter people calculations for how expensive skipping needs to be to deter people
from doing it just to chew up address space. *) from doing it just to chew up address space. *)
let buy (parameter, storage: (bytes * address option) * storage) = let buy (parameter, storage: buy * storage) =
let void: unit = let void: unit =
if Tezos.amount <> storage.2.0 if amount = storage.name_price
then (failwith "Incorrect amount paid.": unit) in then ()
let profile, initial_controller = parameter in else (failwith "Incorrect amount paid.": unit)
let identities, new_id, prices = storage in 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 = let controller: address =
match initial_controller with match initial_controller with
| Some addr -> addr | Some addr -> addr
@ -54,74 +77,84 @@ let buy (parameter, storage: (bytes * address option) * storage) =
profile = profile} in profile = profile} in
let updated_identities : (id, id_details) big_map = let updated_identities : (id, id_details) big_map =
Big_map.update new_id (Some new_id_details) identities Big_map.update new_id (Some new_id_details) identities
in ([]: operation list), (updated_identities, new_id + 1, prices) in
([]: operation list), {storage with identities = updated_identities;
next_id = new_id + 1;
}
let update_owner (parameter, storage : (id * address) * storage) = let update_owner (parameter, storage: update_owner * storage) =
if amount <> 0tez if (amount <> 0mutez)
then (failwith "Updating owner doesn't cost anything.": return) then (failwith "Updating owner doesn't cost anything.": (operation list) * storage)
else else
let id, new_owner = parameter in let id = parameter.id in
let identities, last_id, prices = storage in let new_owner = parameter.new_owner in
let identities = storage.identities in
let current_id_details: id_details = let current_id_details: id_details =
match Big_map.find_opt id identities with match Big_map.find_opt id identities with
| Some id_details -> id_details | Some id_details -> id_details
| None -> (failwith "This ID does not exist." : id_details) in | None -> (failwith "This ID does not exist.": id_details)
let is_allowed : bool = in
if Tezos.sender = current_id_details.owner let u : unit =
then true if sender = current_id_details.owner
else (failwith "You are not the owner of this ID." : bool) in then ()
else failwith "You are not the owner of this ID."
in
let updated_id_details: id_details = { let updated_id_details: id_details = {
owner = new_owner; owner = new_owner;
controller = current_id_details.controller; controller = current_id_details.controller;
profile = current_id_details.profile} in profile = current_id_details.profile;
let updated_identities = }
Big_map.update id (Some updated_id_details) identities in
in ([]: operation list), (updated_identities, last_id, prices) let updated_identities = Big_map.update id (Some updated_id_details) identities in
([]: operation list), {storage with identities = updated_identities}
let update_details (parameter, storage: (id * bytes option * address option) * storage) = let update_details (parameter, storage: update_details * storage) =
if Tezos.amount <> 0tez if (amount <> 0mutez)
then then (failwith "Updating details doesn't cost anything.": (operation list) * storage)
(failwith "Updating details doesn't cost anything." : return)
else else
let id, new_profile, new_controller = parameter in let id = parameter.id in
let identities, last_id, prices = storage 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 = let current_id_details: id_details =
match Big_map.find_opt id identities with match Big_map.find_opt id identities with
| Some id_details -> id_details | Some id_details -> id_details
| None -> (failwith "This ID does not exist.": id_details) in | None -> (failwith "This ID does not exist.": id_details)
let is_allowed : bool = in
if Tezos.sender = current_id_details.controller let u : unit =
|| Tezos.sender = current_id_details.owner if (sender = current_id_details.controller) || (sender = current_id_details.owner)
then true then ()
else else failwith ("You are not the owner or controller of this ID.")
(failwith ("You are not the owner or controller of this ID.") in
: bool) in
let owner: address = current_id_details.owner in let owner: address = current_id_details.owner in
let profile: bytes = let profile: bytes =
match new_profile with match new_profile with
| None -> (* Default *) current_id_details.profile | None -> (* Default *) current_id_details.profile
| Some new_profile -> new_profile in | Some new_profile -> new_profile
in
let controller: address = let controller: address =
match new_controller with match new_controller with
| None -> (* Default *) current_id_details.controller | None -> (* Default *) current_id_details.controller
| Some new_controller -> new_controller in | Some new_controller -> new_controller
in
let updated_id_details: id_details = { let updated_id_details: id_details = {
owner = owner; owner = owner;
controller = controller; controller = controller;
profile = profile} in profile = profile;
}
in
let updated_identities: (id, id_details) big_map = let updated_identities: (id, id_details) big_map =
Big_map.update id (Some updated_id_details) identities Big_map.update id (Some updated_id_details) identities in
in ([]: operation list), (updated_identities, last_id, prices) ([]: operation list), {storage with identities = updated_identities}
(* 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 skip (p,storage: unit * storage) =
let void: unit = let void: unit =
if Tezos.amount <> storage.2.1 if amount = storage.skip_price
then (failwith "Incorrect amount paid." : unit) in then ()
let identities, last_id, prices = storage in else failwith "Incorrect amount paid."
([]: operation list), (identities, last_id + 1, prices) in
([]: operation list), {storage with next_id = storage.next_id + 1}
let main (action, storage : action * storage) : return = let main (action, storage : action * storage) : return =
match action with match action with

167
src/test/contracts/id.religo Normal file
View File

@ -0,0 +1,167 @@
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)), { ...storage,
identities : updated_identities,
next_id : new_id + 1,
});
};
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 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)), { ...storage, identities : updated_identities });
};
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 u: unit =
if ((sender != current_id_details.controller) &&
(sender != current_id_details.owner)) {
failwith ("You are not the owner or controller of this ID.")
}
else { (); };
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)), { ...storage, 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) {
failwith("Incorrect amount paid.");
}
else { (); };
(([]: list(operation)), { ...storage, next_id : storage.next_id + 1 });
};
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))
};
};

243
src/test/examples/cameligo/id.mligo Normal file
View File

@ -0,0 +1,243 @@
(*_*
name: ID Contract (CameLIGO)
language: cameligo
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:
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:
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
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/
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
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)

242
src/test/examples/pascaligo/id.ligo Normal file
View File

@ -0,0 +1,242 @@
(*_*
name: ID Contract (PascaLIGO)
language: pascaligo
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: |
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:
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
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;

248
src/test/examples/reasonligo/id.religo Normal file
View File

@ -0,0 +1,248 @@
/* (*_*
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: |
{
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:
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
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))
};
};

28
src/test/hash_lock_tests.ml
View File

@ -50,7 +50,7 @@ let empty_message = e_lambda (Var.of_name "arguments")
let commit () = 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 predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in
let%bind lock_time = mk_time "2000-01-02T00:10:11Z" 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 let test_hash_raw = sha_256_hash (Bytes.of_string "hello world") in
@ -79,12 +79,12 @@ let commit () =
~sender:first_contract ~sender:first_contract
() ()
in 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) (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 *) (* Test that the contract fails if we haven't committed before revealing the answer *)
let reveal_no_commit () = let reveal_no_commit () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
("message", empty_message)] ("message", empty_message)]
@ -95,13 +95,13 @@ let reveal_no_commit () =
("salted_hash", (t_bytes ()))]) ("salted_hash", (t_bytes ()))])
in in
let init_storage = storage test_hash true pre_commits 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) (e_pair reveal init_storage)
"You have not made a commitment to hash against yet." "You have not made a commitment to hash against yet."
(* Test that the contract fails if our commit isn't 24 hours old yet *) (* Test that the contract fails if our commit isn't 24 hours old yet *)
let reveal_young_commit () = let reveal_young_commit () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
("message", empty_message)] ("message", empty_message)]
@ -128,13 +128,13 @@ let reveal_young_commit () =
~sender:first_contract ~sender:first_contract
() ()
in in
expect_string_failwith ~options program "reveal" expect_string_failwith ~options (program, state) "reveal"
(e_pair reveal init_storage) (e_pair reveal init_storage)
"It has not been 24 hours since your commit yet." "It has not been 24 hours since your commit yet."
(* Test that the contract fails if our reveal doesn't meet our commitment *) (* Test that the contract fails if our reveal doesn't meet our commitment *)
let reveal_breaks_commit () = let reveal_breaks_commit () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
("message", empty_message)] ("message", empty_message)]
@ -160,13 +160,13 @@ let reveal_breaks_commit () =
~sender:first_contract ~sender:first_contract
() ()
in in
expect_string_failwith ~options program "reveal" expect_string_failwith ~options (program, state) "reveal"
(e_pair reveal init_storage) (e_pair reveal init_storage)
"This reveal does not match your commitment." "This reveal does not match your commitment."
(* Test that the contract fails if we reveal the wrong bytes for the stored hash *) (* Test that the contract fails if we reveal the wrong bytes for the stored hash *)
let reveal_wrong_commit () = let reveal_wrong_commit () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello"); let reveal = e_record_ez [("hashable", e_bytes_string "hello");
("message", empty_message)] ("message", empty_message)]
@ -192,13 +192,13 @@ let reveal_wrong_commit () =
~sender:first_contract ~sender:first_contract
() ()
in in
expect_string_failwith ~options program "reveal" expect_string_failwith ~options (program, state) "reveal"
(e_pair reveal init_storage) (e_pair reveal init_storage)
"Your commitment did not match the storage hash." "Your commitment did not match the storage hash."
(* Test that the contract fails if we try to reuse it after unused flag changed *) (* Test that the contract fails if we try to reuse it after unused flag changed *)
let reveal_no_reuse () = let reveal_no_reuse () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello"); let reveal = e_record_ez [("hashable", e_bytes_string "hello");
("message", empty_message)] ("message", empty_message)]
@ -224,13 +224,13 @@ let reveal_no_reuse () =
~sender:first_contract ~sender:first_contract
() ()
in in
expect_string_failwith ~options program "reveal" expect_string_failwith ~options (program, state) "reveal"
(e_pair reveal init_storage) (e_pair reveal init_storage)
"This contract has already been used." "This contract has already been used."
(* Test that the contract executes successfully with valid commit-reveal *) (* Test that the contract executes successfully with valid commit-reveal *)
let reveal () = let reveal () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let empty_message = empty_message in let empty_message = empty_message in
let reveal = e_record_ez [("hashable", e_bytes_string "hello world"); let reveal = e_record_ez [("hashable", e_bytes_string "hello world");
("message", empty_message)] ("message", empty_message)]
@ -257,7 +257,7 @@ let reveal () =
~sender:first_contract ~sender:first_contract
() ()
in in
expect_eq ~options program "reveal" expect_eq ~options (program, state) "reveal"
(e_pair reveal init_storage) (e_pair empty_op_list post_storage) (e_pair reveal init_storage) (e_pair empty_op_list post_storage)
let main = test_suite "Hashlock" [ let main = test_suite "Hashlock" [

284
src/test/id_tests.ml
View File

@ -33,16 +33,17 @@ let (first_owner , first_contract) =
Protocol.Alpha_context.Contract.to_b58check kt , kt Protocol.Alpha_context.Contract.to_b58check kt , kt
let buy_id () = let buy_id () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let owner_addr = addr 5 in let owner_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
("controller", e_address owner_addr) ; ("controller", e_address owner_addr) ;
("profile", owner_website)] ("profile", owner_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
e_int 1; ("next_id", e_int 1) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_addr = first_owner in let new_addr = first_owner in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
@ -54,28 +55,33 @@ let buy_id () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let param = e_pair owner_website (e_some (e_address new_addr)) in let param = e_record_ez [("profile", owner_website) ;
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; ("initial_controller", (e_some (e_address new_addr))) ;
(e_int 1, id_details_2)]) ; ] in
e_int 2; let new_storage = e_record_ez [("identities", (e_big_map
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] [(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 in
let%bind () = expect_eq ~options program "buy" let%bind () = expect_eq ~options (program, state) "buy"
(e_pair param storage) (e_pair param storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
let buy_id_sender_addr () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
("controller", e_address owner_addr) ; ("controller", e_address owner_addr) ;
("profile", owner_website)] ("profile", owner_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
e_int 1; ("next_id", e_int 1) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_addr = first_owner in let new_addr = first_owner in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
@ -87,43 +93,48 @@ let buy_id_sender_addr () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let param = e_pair owner_website (e_typed_none (t_address ())) in let param = e_record_ez [("profile", owner_website) ;
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; ("initial_controller", (e_typed_none (t_address ())))] in
(e_int 1, id_details_2)]) ; let new_storage = e_record_ez [("identities", (e_big_map
e_int 2; [(e_int 0, id_details_1) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] (e_int 1, id_details_2)])) ;
("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let%bind () = expect_eq ~options program "buy" let%bind () = expect_eq ~options (program, state) "buy"
(e_pair param storage) (e_pair param storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
(* Test that contract fails if we attempt to buy an ID for the wrong amount *) (* Test that contract fails if we attempt to buy an ID for the wrong amount *)
let buy_id_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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
("controller", e_address owner_addr) ; ("controller", e_address owner_addr) ;
("profile", owner_website)] ("profile", owner_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1)]) ; let storage = e_record_ez [("identities", (e_big_map [(e_int 0, id_details_1)])) ;
e_int 1; ("next_id", e_int 1) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_addr = first_owner in let new_addr = first_owner in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
~sender:first_contract ~sender:first_contract
~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) () ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.fifty_cents) ()
in in
let param = e_pair owner_website (e_some (e_address new_addr)) in let param = e_record_ez [("profile", owner_website) ;
let%bind () = expect_string_failwith ~options program "buy" ("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." "Incorrect amount paid."
in ok () in ok ()
let update_details_owner () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -144,27 +155,31 @@ let update_details_owner () =
let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ; let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] in ("profile", new_website)] in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let new_storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2_diff)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2_diff)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let details = e_bytes_string "ligolang.org" in let details = e_bytes_string "ligolang.org" in
let param = e_tuple [e_int 1 ; let param = e_record_ez [("id", e_int 1) ;
e_some details ; ("new_profile", e_some details) ;
e_some (e_address new_addr)] in ("new_controller", 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 param storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
let update_details_controller () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -185,28 +200,32 @@ let update_details_controller () =
let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
("controller", e_address owner_addr) ; ("controller", e_address owner_addr) ;
("profile", new_website)] in ("profile", new_website)] in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let new_storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2_diff)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2_diff)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let details = e_bytes_string "ligolang.org" in let details = e_bytes_string "ligolang.org" in
let param = e_tuple [e_int 1 ; let param = e_record_ez [("id", e_int 1) ;
e_some details ; ("new_profile", e_some details) ;
e_some (e_address owner_addr)] in ("new_controller", 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 param storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
(* Test that contract fails when we attempt to update details of nonexistent ID *) (* Test that contract fails when we attempt to update details of nonexistent ID *)
let update_details_nonexistent () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -224,23 +243,25 @@ let update_details_nonexistent () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let details = e_bytes_string "ligolang.org" in let details = e_bytes_string "ligolang.org" in
let param = e_tuple [e_int 2 ; let param = e_record_ez [("id", e_int 2) ;
e_some details ; ("new_profile", e_some details) ;
e_some (e_address owner_addr)] in ("new_controller", 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) (e_pair param storage)
"This ID does not exist." "This ID does not exist."
in ok () in ok ()
(* Test that contract fails when we attempt to update details from wrong addr *) (* Test that contract fails when we attempt to update details from wrong addr *)
let update_details_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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -257,23 +278,25 @@ let update_details_wrong_addr () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let details = e_bytes_string "ligolang.org" in let details = e_bytes_string "ligolang.org" in
let param = e_tuple [e_int 0 ; let param = e_record_ez [("id", e_int 0) ;
e_some details ; ("new_profile", e_some details) ;
e_some (e_address owner_addr)] in ("new_controller", 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) (e_pair param storage)
"You are not the owner or controller of this ID." "You are not the owner or controller of this ID."
in ok () in ok ()
(* Test that giving none on both profile and controller address is a no-op *) (* Test that giving none on both profile and controller address is a no-op *)
let update_details_unchanged () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -291,21 +314,23 @@ let update_details_unchanged () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let param = e_tuple [e_int 1 ; let param = e_record_ez [("id", e_int 1) ;
e_typed_none (t_bytes ()) ; ("new_profile", e_typed_none (t_bytes ())) ;
e_typed_none (t_address ())] in ("new_controller", 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 param storage)
(e_pair (e_list []) storage) (e_pair (e_list []) storage)
in ok () in ok ()
let update_owner () = let update_owner () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let owner_addr = addr 5 in let owner_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -326,25 +351,30 @@ let update_owner () =
let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ; let id_details_2_diff = e_record_ez [("owner", e_address owner_addr) ;
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] in ("profile", new_website)] in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let new_storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2_diff)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2_diff)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let param = e_pair (e_int 1) (e_address owner_addr) in let param = e_record_ez [("id", e_int 1) ;
let%bind () = expect_eq ~options program "update_owner" ("new_owner", e_address owner_addr)] in
let%bind () = expect_eq ~options (program, state) "update_owner"
(e_pair param storage) (e_pair param storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
(* Test that contract fails when we attempt to update owner of nonexistent ID *) (* Test that contract fails when we attempt to update owner of nonexistent ID *)
let update_owner_nonexistent () = 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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -362,20 +392,23 @@ let update_owner_nonexistent () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let param = e_pair (e_int 2) (e_address new_addr) in let param = e_record_ez [("id", e_int 2);
let%bind () = expect_string_failwith ~options program "update_owner" ("new_owner", e_address new_addr)] in
let%bind () = expect_string_failwith ~options (program, state) "update_owner"
(e_pair param storage) (e_pair param storage)
"This ID does not exist." "This ID does not exist."
in ok () in ok ()
(* Test that contract fails when we attempt to update owner from non-owner addr *) (* Test that contract fails when we attempt to update owner from non-owner addr *)
let update_owner_wrong_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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -393,19 +426,22 @@ let update_owner_wrong_addr () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let param = e_pair (e_int 0) (e_address new_addr) in let param = e_record_ez [("id", e_int 0);
let%bind () = expect_string_failwith ~options program "update_owner" ("new_owner", e_address new_addr)] in
let%bind () = expect_string_failwith ~options (program, state) "update_owner"
(e_pair param storage) (e_pair param storage)
"You are not the owner of this ID." "You are not the owner of this ID."
in ok () in ok ()
let skip () = let skip () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let owner_addr = addr 5 in let owner_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -422,24 +458,28 @@ let skip () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let new_storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let new_storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 3; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 3) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let%bind () = expect_eq ~options program "skip" let%bind () = expect_eq ~options (program, state) "skip"
(e_pair (e_unit ()) storage) (e_pair (e_unit ()) storage)
(e_pair (e_list []) new_storage) (e_pair (e_list []) new_storage)
in ok () in ok ()
(* Test that contract fails if we try to skip without paying the right amount *) (* Test that contract fails if we try to skip without paying the right amount *)
let skip_wrong_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_addr = addr 5 in
let owner_website = e_bytes_string "ligolang.org" in let owner_website = e_bytes_string "ligolang.org" in
let id_details_1 = e_record_ez [("owner", e_address owner_addr) ; let id_details_1 = e_record_ez [("owner", e_address owner_addr) ;
@ -456,17 +496,19 @@ let skip_wrong_amount () =
("controller", e_address new_addr) ; ("controller", e_address new_addr) ;
("profile", new_website)] ("profile", new_website)]
in in
let storage = e_tuple [(e_big_map [(e_int 0, id_details_1) ; let storage = e_record_ez [("identities", (e_big_map
(e_int 1, id_details_2)]) ; [(e_int 0, id_details_1) ;
e_int 2; (e_int 1, id_details_2)])) ;
e_tuple [e_mutez 1000000 ; e_mutez 1000000]] ("next_id", e_int 2) ;
("name_price", e_mutez 1000000) ;
("skip_price", e_mutez 1000000) ; ]
in in
let%bind () = expect_string_failwith ~options program "skip" let%bind () = expect_string_failwith ~options (program, state) "skip"
(e_pair (e_unit ()) storage) (e_pair (e_unit ()) storage)
"Incorrect amount paid." "Incorrect amount paid."
in ok () in ok ()
let main = test_suite "ID Layer" [ let main = test_suite "ID Layer (CameLIGO)" [
test "buy" buy_id ; test "buy" buy_id ;
test "buy (sender addr)" buy_id_sender_addr ; test "buy (sender addr)" buy_id_sender_addr ;
test "buy (wrong amount)" buy_id_wrong_amount ; test "buy (wrong amount)" buy_id_wrong_amount ;

522
src/test/id_tests_p.ml Normal file
View File

@ -0,0 +1,522 @@
open Trace
open Test_helpers
open Ast_imperative
let type_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" (Contract "main") in
ok (typed,state)
let get_program =
let s = ref None in
fun () -> match !s with
| Some s -> ok s
| None -> (
let%bind program = type_file "./contracts/id.ligo" in
s := Some program ;
ok program
)
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 (_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, 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) ;
("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 id_details_2 = e_record_ez [("owner", e_address new_addr) ;
("controller", e_address new_addr) ;
("profile", owner_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, 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 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 id_details_2 = e_record_ez [("owner", e_address new_addr) ;
("controller", e_address new_addr) ;
("profile", owner_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 id_details_2 = e_record_ez [("owner", e_address new_addr) ;
("controller", e_address owner_addr) ;
("profile", owner_website)]
in
let id_details_2_diff = e_record_ez [("owner", e_address new_addr) ;
("controller", e_address new_addr) ;
("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)])) ;
("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 = 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
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 = owner_website 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 (PascaLIGO)" [
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 ;
]

525
src/test/id_tests_r.ml Normal file
View File

@ -0,0 +1,525 @@
open Trace
open Test_helpers
open Ast_imperative
let retype_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" (Contract "main") in
ok (typed,state)
let get_program =
let s = ref None in
fun () -> match !s with
| Some s -> ok s
| None -> (
let%bind program = retype_file "./contracts/id.religo" in
s := Some program ;
ok program
)
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 (_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 ;
]

12
src/test/integration_tests.ml
View File

@ -4,17 +4,11 @@ open Test_helpers
open Ast_imperative.Combinators open Ast_imperative.Combinators
let retype_file f = let retype_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "reasonligo" Env in Ligo.Compile.Utils.type_file f "reasonligo" Env
let () = Typer.Solver.discard_state state in
ok typed
let mtype_file f = let mtype_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" Env in Ligo.Compile.Utils.type_file f "cameligo" Env
let () = Typer.Solver.discard_state state in
ok typed
let type_file f = let type_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "pascaligo" Env in Ligo.Compile.Utils.type_file f "pascaligo" Env
let () = Typer.Solver.discard_state state in
ok typed
let type_alias () : unit result = let type_alias () : unit result =
let%bind program = type_file "./contracts/type-alias.ligo" in let%bind program = type_file "./contracts/type-alias.ligo" in

28
src/test/multisig_tests.ml
View File

@ -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 *) (* Provide one valid signature when the threshold is two of two keys *)
let not_enough_1_of_2 f s () = 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 exp_failwith = "Not enough signatures passed the check" in
let keys = gen_keys () in let keys = gen_keys () in
let%bind test_params = params 0 empty_message [keys] [true] f s in let%bind test_params = params 0 empty_message [keys] [true] f s in
let%bind () = expect_string_failwith 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 () ok ()
let unmatching_counter f s () = 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 exp_failwith = "Counters does not match" in
let keys = gen_keys () in let keys = gen_keys () in
let%bind test_params = params 1 empty_message [keys] [true] f s in let%bind test_params = params 1 empty_message [keys] [true] f s in
let%bind () = expect_string_failwith 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 () ok ()
(* Provide one invalid signature (correct key but incorrect signature) (* Provide one invalid signature (correct key but incorrect signature)
when the threshold is one of one key *) when the threshold is one of one key *)
let invalid_1_of_1 f s () = 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 exp_failwith = "Invalid signature" in
let keys = [gen_keys ()] in let keys = [gen_keys ()] in
let%bind test_params = params 0 empty_message keys [false] f s in let%bind test_params = params 0 empty_message keys [false] f s in
let%bind () = expect_string_failwith 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 () ok ()
(* Provide one valid signature when the threshold is one of one key *) (* Provide one valid signature when the threshold is one of one key *)
let valid_1_of_1 f s () = 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 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 -> (fun n ->
let%bind params = params n empty_message [keys] [true] f s in let%bind params = params n empty_message [keys] [true] f s in
ok @@ e_pair params (init_storage 1 n [keys]) 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 *) (* Provive two valid signatures when the threshold is two of three keys *)
let valid_2_of_3 f s () = 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 param_keys = [gen_keys (); gen_keys ()] in
let st_keys = param_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 -> (fun n ->
let%bind params = params n empty_message param_keys [true;true] f s in let%bind params = params n empty_message param_keys [true;true] f s in
ok @@ e_pair params (init_storage 2 n st_keys) 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 *) (* Provide one invalid signature and two valid signatures when the threshold is two of three keys *)
let invalid_3_of_3 f s () = 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 valid_keys = [gen_keys() ; gen_keys()] in
let invalid_key = gen_keys () in let invalid_key = gen_keys () in
let param_keys = valid_keys @ [invalid_key] 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%bind test_params = params 0 empty_message param_keys [false;true;true] f s in
let exp_failwith = "Invalid signature" in let exp_failwith = "Invalid signature" in
let%bind () = expect_string_failwith 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 () ok ()
(* Provide two valid signatures when the threshold is three of three keys *) (* Provide two valid signatures when the threshold is three of three keys *)
let not_enough_2_of_3 f s () = 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 valid_keys = [gen_keys() ; gen_keys()] in
let st_keys = gen_keys () :: valid_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%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 exp_failwith = "Not enough signatures passed the check" in
let%bind () = expect_string_failwith 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 () ok ()
let main = test_suite "Multisig" [ let main = test_suite "Multisig" [

40
src/test/multisig_v2_tests.ml
View File

@ -65,7 +65,7 @@ let storage {state_hash ; threshold ; max_proposal ; max_msg_size ; id_counter_l
(* sender not stored in the authorized set *) (* sender not stored in the authorized set *)
let wrong_addr () = let wrong_addr () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage { let init_storage = storage {
threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ;
id_counter_list = [1,0 ; 2,0] ; 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 options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
let%bind () = let%bind () =
let exp_failwith = "Unauthorized address" in 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 (e_pair (send_param empty_message) init_storage) exp_failwith in
ok () ok ()
(* send a message which exceed the size limit *) (* send a message which exceed the size limit *)
let message_size_exceeded () = let message_size_exceeded () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage { let init_storage = storage {
threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; threshold = 1 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ;
id_counter_list = [1,0] ; 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 options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
let%bind () = let%bind () =
let exp_failwith = "Message size exceed maximum limit" in 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 (e_pair (send_param empty_message) init_storage) exp_failwith in
ok () ok ()
(* sender has already has reached maximum number of proposal *) (* sender has already has reached maximum number of proposal *)
let 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%bind packed_payload1 = pack_payload program (send_param empty_message) in
let bytes1 = e_bytes_raw packed_payload1 in let bytes1 = e_bytes_raw packed_payload1 in
let init_storage = storage { 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 options = Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
let%bind () = let%bind () =
let exp_failwith = "Maximum number of proposal reached" in 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 (e_pair (send_param empty_message2) init_storage) exp_failwith in
ok () ok ()
(* sender message is already stored in the message store *) (* sender message is already stored in the message store *)
let send_already_accounted () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let init_storage = storage { let init_storage = storage {
@ -126,12 +126,12 @@ let send_already_accounted () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (e_pair (send_param empty_message) init_storage) (e_pair empty_op_list init_storage)
(* sender message isn't stored in the message store *) (* sender message isn't stored in the message store *)
let send_never_accounted () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let init_storage' = { let init_storage' = {
@ -147,12 +147,12 @@ let send_never_accounted () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (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 *) (* sender withdraw message is already binded to one address in the message store *)
let withdraw_already_accounted_one () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let param = withdraw_param in let param = withdraw_param in
@ -168,12 +168,12 @@ let withdraw_already_accounted_one () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (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 *) (* sender withdraw message is already binded to two addresses in the message store *)
let withdraw_already_accounted_two () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let param = withdraw_param in let param = withdraw_param in
@ -189,12 +189,12 @@ let withdraw_already_accounted_two () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (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 *) (* triggers the threshold and check that all the participants get their counters decremented *)
let counters_reset () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let param = send_param empty_message in let param = send_param empty_message in
@ -212,12 +212,12 @@ let counters_reset () =
let options = let options =
let sender = contract 3 in let sender = contract 3 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (e_pair param init_storage) (e_pair empty_op_list final_storage)
(* sender withdraw message was never accounted *) (* sender withdraw message was never accounted *)
let withdraw_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 param = withdraw_param in
let init_storage = storage { let init_storage = storage {
threshold = 2 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ; threshold = 2 ; max_proposal = 1 ; max_msg_size = 1 ; state_hash = Bytes.empty ;
@ -227,12 +227,12 @@ let withdraw_never_accounted () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (e_pair param init_storage) (e_pair empty_op_list init_storage)
(* successful storing in the message store *) (* successful storing in the message store *)
let succeeded_storing () = 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%bind packed_payload = pack_payload program empty_message in
let bytes = e_bytes_raw packed_payload in let bytes = e_bytes_raw packed_payload in
let init_storage th = { let init_storage th = {
@ -243,7 +243,7 @@ let succeeded_storing () =
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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 -> (fun th ->
let init_storage = storage (init_storage th) in let init_storage = storage (init_storage th) in
ok @@ e_pair (send_param empty_message) init_storage ok @@ e_pair (send_param empty_message) init_storage

12
src/test/pledge_tests.ml
View File

@ -45,36 +45,36 @@ let empty_message = e_lambda (Var.of_name "arguments")
let pledge () = let pledge () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let storage = e_address oracle_addr in let storage = e_address oracle_addr in
let parameter = e_unit () in let parameter = e_unit () in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
~sender:oracle_contract ~sender:oracle_contract
~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) () ~amount:(Memory_proto_alpha.Protocol.Alpha_context.Tez.one) ()
in in
expect_eq ~options program "donate" expect_eq ~options (program, state) "donate"
(e_pair parameter storage) (e_pair parameter storage)
(e_pair (e_list []) storage) (e_pair (e_list []) storage)
let distribute () = let distribute () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let storage = e_address oracle_addr in let storage = e_address oracle_addr in
let parameter = empty_message in let parameter = empty_message in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
~sender:oracle_contract () ~sender:oracle_contract ()
in in
expect_eq ~options program "distribute" expect_eq ~options (program, state) "distribute"
(e_pair parameter storage) (e_pair parameter storage)
(e_pair (e_list []) storage) (e_pair (e_list []) storage)
let distribute_unauthorized () = let distribute_unauthorized () =
let%bind program, _ = get_program () in let%bind (program , state) = get_program () in
let storage = e_address oracle_addr in let storage = e_address oracle_addr in
let parameter = empty_message in let parameter = empty_message in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options let options = Proto_alpha_utils.Memory_proto_alpha.make_options
~sender:stranger_contract () ~sender:stranger_contract ()
in in
expect_string_failwith ~options program "distribute" expect_string_failwith ~options (program, state) "distribute"
(e_pair parameter storage) (e_pair parameter storage)
"You're not the oracle for this distribution." "You're not the oracle for this distribution."

16
src/test/replaceable_id_tests.ml
View File

@ -39,45 +39,45 @@ let entry_pass_message = e_constructor "Pass_message"
@@ empty_message @@ empty_message
let change_addr_success () = let change_addr_success () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage 1 in let init_storage = storage 1 in
let param = entry_change_addr 2 in let param = entry_change_addr 2 in
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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)) (e_pair param init_storage) (e_pair empty_op_list (storage 2))
let change_addr_fail () = let change_addr_fail () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage 1 in let init_storage = storage 1 in
let param = entry_change_addr 2 in let param = entry_change_addr 2 in
let options = let options =
let sender = contract 3 in let sender = contract 3 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
let exp_failwith = "Unauthorized 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 (e_pair param init_storage) exp_failwith
let pass_message_success () = let pass_message_success () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage 1 in let init_storage = storage 1 in
let param = entry_pass_message in let param = entry_pass_message in
let options = let options =
let sender = contract 1 in let sender = contract 1 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () 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) (e_pair param init_storage) (e_pair empty_op_list init_storage)
let pass_message_fail () = let pass_message_fail () =
let%bind program,_ = get_program () in let%bind (program , state) = get_program () in
let init_storage = storage 1 in let init_storage = storage 1 in
let param = entry_pass_message in let param = entry_pass_message in
let options = let options =
let sender = contract 2 in let sender = contract 2 in
Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in Proto_alpha_utils.Memory_proto_alpha.make_options ~sender () in
let exp_failwith = "Unauthorized 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 (e_pair param init_storage) exp_failwith
let main = test_suite "Replaceable ID" [ let main = test_suite "Replaceable ID" [

2
src/test/test.ml
View File

@ -11,6 +11,8 @@ let () =
Coase_tests.main ; Coase_tests.main ;
Vote_tests.main ; Vote_tests.main ;
Id_tests.main ; Id_tests.main ;
Id_tests_p.main ;
Id_tests_r.main ;
Multisig_tests.main ; Multisig_tests.main ;
Multisig_v2_tests.main ; Multisig_v2_tests.main ;
Replaceable_id_tests.main ; Replaceable_id_tests.main ;

17
src/test/test_helpers.ml
View File

@ -38,7 +38,7 @@ open Ast_imperative
let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result = let pack_payload (program:Ast_typed.program) (payload:expression) : bytes result =
let%bind code = 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 sugar = Compile.Of_imperative.compile_expression payload in
let%bind core = Compile.Of_sugar.compile_expression sugar in let%bind core = Compile.Of_sugar.compile_expression sugar in
@ -86,11 +86,10 @@ let sha_256_hash pl =
open Ast_imperative.Combinators open Ast_imperative.Combinators
let typed_program_with_imperative_input_to_michelson 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 = (input: Ast_imperative.expression) : Compiler.compiled_expression result =
Printexc.record_backtrace true; 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 sugar = Compile.Of_imperative.compile_expression input in
let%bind core = Compile.Of_sugar.compile_expression sugar in let%bind core = Compile.Of_sugar.compile_expression sugar in
let%bind app = Compile.Of_core.apply entry_point core 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 Compile.Of_mini_c.aggregate_and_compile_expression mini_c_prg compiled_applied
let run_typed_program_with_imperative_input ?options 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 = (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 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 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 Ast_core.Misc.assert_value_eq (expected,result) in
expect ?options program entry_point input expecter 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 error =
let title () = "expect evaluate" in let title () = "expect evaluate" in
let content () = Format.asprintf "Entry_point: %s" entry_point 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 let%bind res_simpl = Uncompile.uncompile_typed_program_entry_expression_result program entry_point res_michelson in
expecter res_simpl 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%bind expected = expression_to_core expected in
let expecter = fun result -> let expecter = fun result ->
Ast_core.Misc.assert_value_eq (expected , result) in 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 expect_n_aux ?options lst program entry_point make_input make_expecter =
let aux n = let aux n =

8
src/test/time_lock_repeat_tests.ml
View File

@ -43,21 +43,21 @@ let storage st interval execute =
("execute", execute)] ("execute", execute)]
let early_call () = 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 predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T10: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 init_storage = storage lock_time 86400 empty_message in
let options = let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in 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 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 (e_pair (e_unit ()) init_storage) exp_failwith
let fake_uncompiled_empty_message = e_string "[lambda of type: (lambda unit (list operation)) ]" 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 *) (* Test that when we use the contract the next use time advances by correct interval *)
let interval_advance () = 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 predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T00: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 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 new_storage_fake = storage new_timestamp 86400 fake_uncompiled_empty_message in
let options = let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in 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) (e_pair (e_unit ()) init_storage) (e_pair empty_op_list new_storage_fake)
let main = test_suite "Time Lock Repeating" [ let main = test_suite "Time Lock Repeating" [

8
src/test/time_lock_tests.ml
View File

@ -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 storage st = e_timestamp (Int64.to_int @@ to_sec st)
let early_call () = 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 predecessor_timestamp = mk_time "2000-01-01T00:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in let%bind lock_time = mk_time "2000-01-01T10:10:10Z" in
let init_storage = storage lock_time in let init_storage = storage lock_time in
let options = let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in
let exp_failwith = "Contract is still time locked" 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 (e_pair (call empty_message) init_storage) exp_failwith
let call_on_time () = 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 predecessor_timestamp = mk_time "2000-01-01T10:10:10Z" in
let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in let%bind lock_time = mk_time "2000-01-01T00:10:10Z" in
let init_storage = storage lock_time in let init_storage = storage lock_time in
let options = let options =
Proto_alpha_utils.Memory_proto_alpha.make_options ~predecessor_timestamp () in 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) (e_pair (call empty_message) init_storage) (e_pair empty_op_list init_storage)
let main = test_suite "Time lock" [ let main = test_suite "Time lock" [

4
src/test/typer_tests.ml
View File

@ -34,7 +34,7 @@ module TestExpressions = struct
module I = Simplified.Combinators module I = Simplified.Combinators
module O = Typed.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 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 ()) 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 "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}) ] (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ]
in test_expression 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))) I.(e_constructor "foo" (e_int (Z.of_int 32)))
O.(make_t_ez_sum variant_foo_bar) O.(make_t_ez_sum variant_foo_bar)

32
src/test/tzip12_tests.ml
View File

@ -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 external_contract = e_annotation (e_constant C_IMPLICIT_ACCOUNT [e_key_hash external_contract]) (t_contract (t_nat ()))
let transfer f s () = 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 input = e_pair parameter storage in
let expected = e_pair (e_typed_list [] (t_operation ())) new_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 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 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 parameter = e_record_ez [("address_from", from_);("address_to",to_); ("value",e_nat 10)] in
let input = e_pair parameter storage in let input = e_pair parameter storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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" "Not Enough Allowance"
let transfer_not_e_balance f s () = 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 0); (to_, e_nat 100)]); ("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)]); ("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 parameter = e_record_ez [("address_from", from_);("address_to",to_); ("value",e_nat 10)] in
let input = e_pair parameter storage in let input = e_pair parameter storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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" "Not Enough Balance"
let approve f s () = 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 input = e_pair parameter storage in
let expected = e_pair (e_typed_list [] (t_operation ())) new_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 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 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 parameter = e_record_ez [("spender", from_);("value",e_nat 100)] in
let input = e_pair parameter storage in let input = e_pair parameter storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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" "Unsafe Allowance Change"
let get_allowance f s () = 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 input = e_pair parameter storage in
let expected = e_pair (e_typed_list [] (t_operation ())) storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 input = e_pair parameter storage in
let expected = e_pair (e_typed_list [] (t_operation ())) storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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 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 [ let storage = e_record_ez [
("tokens", e_big_map [(sender, e_nat 100); (from_, e_nat 100); (to_, e_nat 100)]); ("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)]); ("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 input = e_pair parameter storage in
let expected = e_pair (e_typed_list [] (t_operation ())) storage in let expected = e_pair (e_typed_list [] (t_operation ())) storage in
let options = Proto_alpha_utils.Memory_proto_alpha.make_options () 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" [ let main = test_suite "tzip-12" [
test "transfer" (transfer file_FA12 "pascaligo"); test "transfer" (transfer file_FA12 "pascaligo");

7
src/test/vote_tests.ml
View File

@ -2,8 +2,7 @@ open Trace
open Test_helpers open Test_helpers
let type_file f = let type_file f =
let%bind typed,state = Ligo.Compile.Utils.type_file f "cameligo" (Contract "main") in Ligo.Compile.Utils.type_file f "cameligo" (Contract "main")
ok @@ (typed,state)
let get_program = let get_program =
let s = ref None in 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 yea = e_constructor "Vote" (e_constructor "Yea" (e_unit ()))
let init_vote () = let init_vote () =
let%bind (program , _) = get_program () in let%bind (program , state) = get_program () in
let%bind result = let%bind result =
Test_helpers.run_typed_program_with_imperative_input 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_pair result in
let%bind storage' = Ast_core.extract_record storage in let%bind storage' = Ast_core.extract_record storage in
(* let votes = List.assoc (Label "voters") storage' in (* let votes = List.assoc (Label "voters") storage' in

15
tools/webide/packages/client/package-examples.js
View File

@ -4,12 +4,6 @@ const join = require('path').join;
const fs = require('fs'); const fs = require('fs');
const YAML = require('yamljs'); const YAML = require('yamljs');
const CURATED_EXAMPLES = [
'cameligo/arithmetic-contract.ligo',
'pascaligo/arithmetic-contract.ligo',
'reasonligo/arithmetic-contract.ligo'
];
function urlFriendlyHash(content) { function urlFriendlyHash(content) {
const hash = createHash('md5'); const hash = createHash('md5');
hash.update(content); hash.update(content);
@ -109,6 +103,15 @@ async function main() {
// const EXAMPLES_GLOB = '**/*.ligo'; // const EXAMPLES_GLOB = '**/*.ligo';
// const files = await findFiles(EXAMPLES_GLOB, EXAMPLES_DIR); // 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'); const EXAMPLES_DEST_DIR = join(process.cwd(), 'build', 'static', 'examples');
fs.mkdirSync(EXAMPLES_DEST_DIR, { recursive: true }); fs.mkdirSync(EXAMPLES_DEST_DIR, { recursive: true });

9
tools/webide/packages/client/src/redux/examples.ts
View File

@ -33,9 +33,12 @@ export const DEFAULT_STATE: ExamplesState = {
if (process.env.NODE_ENV === 'development') { if (process.env.NODE_ENV === 'development') {
DEFAULT_STATE.list = [ DEFAULT_STATE.list = [
{ id: 'MzkMQ1oiVHJqbcfUuVFKTw', name: 'CameLIGO Contract' }, { id: 'MzkMQ1oiVHJqbcfUuVFKTw', name: 'Increment Example CameLIGO ' },
{ id: 'FEb62HL7onjg1424eUsGSg', name: 'PascaLIGO Contract' }, { id: 'FEb62HL7onjg1424eUsGSg', name: 'Increment Example PascaLIGO' },
{ id: 'JPhSOehj_2MFwRIlml0ymQ', name: 'ReasonLIGO Contract' } { 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' },
]; ];
} }

2
tools/webide/packages/e2e/test/share.spec.js
View File

@ -24,7 +24,7 @@ describe('Share', () => {
await responseCallback; await responseCallback;
const actualShareLink = await page.evaluate(getInputValue, 'share-link'); 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); expect(actualShareLink).toEqual(expectedShareLink);
done(); done();

11
vendors/Red-Black_Trees/PolySet.ml vendored
View File

@ -23,6 +23,17 @@ let find elt set =
let find_opt elt set = RB.find_opt ~cmp:set.cmp elt set.tree 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 elements set = RB.elements set.tree
let iter f set = RB.iter f set.tree let iter f set = RB.iter f set.tree

18
vendors/Red-Black_Trees/PolySet.mli vendored
View File

@ -46,10 +46,28 @@ val find : 'elt -> 'elt t -> 'elt
val find_opt : 'elt -> 'elt t -> 'elt option 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 (* 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 set [set] in increasing order (with respect to the total comparison
function used to create the set). *) 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 val elements : 'elt t -> 'elt list
(* The side-effect of evaluating the call [iter f set] is the (* The side-effect of evaluating the call [iter f set] is the