From 84d8da97ec5c286208cc3469f3312846fe425fb2 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 25 Mar 2020 14:47:41 -0500 Subject: [PATCH 1/8] Delete flaky webide test (for now) --- tools/webide/packages/e2e/test/deploy.spec.js | 38 ------------------- 1 file changed, 38 deletions(-) delete mode 100644 tools/webide/packages/e2e/test/deploy.spec.js diff --git a/tools/webide/packages/e2e/test/deploy.spec.js b/tools/webide/packages/e2e/test/deploy.spec.js deleted file mode 100644 index 958774cae..000000000 --- a/tools/webide/packages/e2e/test/deploy.spec.js +++ /dev/null @@ -1,38 +0,0 @@ -const commonUtils = require('./common-utils'); - -const API_HOST = commonUtils.API_HOST; - -const runCommandAndGetOutputFor = commonUtils.runCommandAndGetOutputFor; -const clearText = commonUtils.clearText; - -const COMMAND = 'deploy'; -const COMMAND_ENDPOINT = 'deploy'; - -async function deploy() { - return await runCommandAndGetOutputFor(COMMAND, COMMAND_ENDPOINT); -} - -describe('Deploy contract', () => { - beforeAll(() => jest.setTimeout(60000)); - - beforeEach(async () => await page.goto(API_HOST)); - - it('should deploy', async done => { - expect(await deploy()).toContain('The contract was successfully deployed to the carthage test network.'); - - done(); - }); - - it('should fail to deploy contract with invalid storage', async done => { - await page.click('#command-select'); - await page.click(`#deploy`); - - await page.click(`#storage`); - await clearText(page.keyboard); - await page.keyboard.type('asdf'); - - expect(await deploy()).toContain('Error: '); - - done(); - }); -}); From 0d46be7425cce2f173a610d327872923f3bd9186 Mon Sep 17 00:00:00 2001 From: Sander Spies Date: Tue, 31 Mar 2020 17:00:17 +0200 Subject: [PATCH 2/8] Change not existing mutez type to existing tez type --- gitlab-pages/docs/reference/current.md | 18 +++++++++--------- src/passes/1-parser/pascaligo/Doc/pascaligo.md | 2 +- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/gitlab-pages/docs/reference/current.md b/gitlab-pages/docs/reference/current.md index 56c719630..a08916711 100644 --- a/gitlab-pages/docs/reference/current.md +++ b/gitlab-pages/docs/reference/current.md @@ -21,13 +21,13 @@ type timestamp A date in the real world. -type mutez +type tez -type mutez +type tez -type mutez +type tez A specific type for tokens. @@ -83,13 +83,13 @@ type chain_id The identifier of a chain, used to indicate test or main chains. -function balance : mutez +function balance : tez -val balance : mutez +val balance : tez -let balance: mutez +let balance: tez Get the balance for the contract. @@ -263,13 +263,13 @@ let not_tomorrow: bool = (Tezos.now == in_24_hrs); -function amount : mutez +function amount : tez -val amount : mutez +val amount : tez -let amount: mutez +let amount: tez Get the amount of tez provided by the sender to complete this diff --git a/src/passes/1-parser/pascaligo/Doc/pascaligo.md b/src/passes/1-parser/pascaligo/Doc/pascaligo.md index 1415631fd..ba6010ea8 100644 --- a/src/passes/1-parser/pascaligo/Doc/pascaligo.md +++ b/src/passes/1-parser/pascaligo/Doc/pascaligo.md @@ -823,7 +823,7 @@ example, in verbose style: type store is record - goal : mutez; // Millionth of a tez + goal : tez; deadline : timestamp; backers : map (address, nat); funded : bool From 13e9405deef00d6eb3cc0c4cf0ca12320a9b6f2b Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Wed, 25 Mar 2020 15:22:26 +0100 Subject: [PATCH 3/8] adding tuples in ast_sugar --- src/passes/10-interpreter/interpreter.ml | 4 +- src/passes/10-transpiler/transpiler.ml | 16 +-- src/passes/10-transpiler/untranspiler.ml | 2 +- .../entrypoints_length_limit.ml | 2 +- src/passes/3-self_ast_imperative/helpers.ml | 48 ++++++- .../imperative_to_sugar.ml | 41 ++++-- src/passes/5-self_ast_sugar/helpers.ml | 48 ++++++- src/passes/6-sugar_to_core/sugar_to_core.ml | 38 +++-- src/passes/8-typer-new/typer.ml | 14 +- src/passes/8-typer-old/typer.ml | 14 +- src/passes/9-self_ast_typed/helpers.ml | 12 +- src/stages/1-ast_imperative/PP.ml | 46 +++++- src/stages/1-ast_imperative/combinators.ml | 48 ++----- src/stages/1-ast_imperative/misc.ml | 23 ++- src/stages/1-ast_imperative/types.ml | 47 +++++-- src/stages/2-ast_sugar/PP.ml | 40 +++++- src/stages/2-ast_sugar/combinators.ml | 42 ++---- src/stages/2-ast_sugar/combinators.mli | 6 +- src/stages/2-ast_sugar/misc.ml | 23 ++- src/stages/2-ast_sugar/types.ml | 47 +++++-- src/stages/3-ast_core/PP.ml | 2 +- src/stages/3-ast_core/combinators.ml | 29 ++-- src/stages/3-ast_core/combinators.mli | 8 +- src/stages/3-ast_core/types.ml | 9 +- src/stages/4-ast_typed/PP.ml | 2 +- src/stages/4-ast_typed/combinators.ml | 2 +- src/stages/4-ast_typed/types.ml | 10 +- src/stages/common/PP.ml | 132 +++++++----------- src/stages/common/helpers.ml | 20 +++ src/stages/common/helpers.mli | 5 + src/stages/typesystem/misc.ml | 8 +- src/test/contracts/tuple.ligo | 9 +- src/test/integration_tests.ml | 7 +- 33 files changed, 520 insertions(+), 284 deletions(-) diff --git a/src/passes/10-interpreter/interpreter.ml b/src/passes/10-interpreter/interpreter.ml index d319d49a7..f4d930298 100644 --- a/src/passes/10-interpreter/interpreter.ml +++ b/src/passes/10-interpreter/interpreter.ml @@ -303,12 +303,12 @@ and eval : Ast_typed.expression -> env -> value result ok (label,v')) (LMap.to_kv_list recmap) in ok @@ V_Record (LMap.of_list lv') - | E_record_accessor { record ; label} -> ( + | E_record_accessor { record ; path} -> ( let%bind record' = eval record env in match record' with | V_Record recmap -> let%bind a = trace_option (simple_error "unknown record field") @@ - LMap.find_opt label recmap in + LMap.find_opt path recmap in ok a | _ -> simple_fail "trying to access a non-record" ) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 04ceeaf8d..5f89f5a20 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -172,7 +172,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result = aux node in ok @@ snd m' | T_record m -> - let node = Append_tree.of_list @@ kv_list_of_lmap m in + let node = Append_tree.of_list @@ Stage_common.Helpers.kv_list_of_record_or_tuple m in let aux a b : type_value annotated result = let%bind a = a in let%bind b = b in @@ -191,7 +191,7 @@ let rec transpile_type (t:AST.type_expression) : type_value result = ) let record_access_to_lr : type_value -> type_value AST.label_map -> AST.label -> (type_value * [`Left | `Right]) list result = fun ty tym ind -> - let tys = kv_list_of_lmap tym in + let tys = Stage_common.Helpers.kv_list_of_record_or_tuple tym in let node_tv = Append_tree.of_list tys in let%bind path = let aux (i , _) = i = ind in @@ -290,7 +290,8 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = return ~tv ae ) | E_record m -> ( - let node = Append_tree.of_list @@ list_of_lmap m in + (*list_of_lmap to record_to_list*) + let node = Append_tree.of_list @@ Stage_common.Helpers.list_of_record_or_tuple m in let aux a b : expression result = let%bind a = a in let%bind b = b in @@ -302,16 +303,15 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = trace_strong (corner_case ~loc:__LOC__ "record build") @@ Append_tree.fold_ne (transpile_annotated_expression) aux node ) - | E_record_accessor {record; label} -> - let ty = get_type_expression record in - let%bind ty' = transpile_type ty in + | E_record_accessor {record; path} -> + let%bind ty' = transpile_type (get_type_expression record) in let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ - get_t_record ty in + get_t_record (get_type_expression record) in let%bind ty'_lmap = Stage_common.Helpers.bind_map_lmap transpile_type ty_lmap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ - record_access_to_lr ty' ty'_lmap label in + record_access_to_lr ty' ty'_lmap path in let aux = fun pred (ty, lr) -> let c = match lr with | `Left -> C_CAR diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index b8762ecf1..3665f8063 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -232,7 +232,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind sub = untranspile v tv in return (E_constructor {constructor=Constructor name;element=sub}) | T_record m -> - let lst = kv_list_of_lmap m in + let lst = Stage_common.Helpers.kv_list_of_record_or_tuple m in let%bind node = match Append_tree.of_list lst with | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Full t -> ok t in diff --git a/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml b/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml index f2d5fc202..e9809c835 100644 --- a/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml +++ b/src/passes/3-self_ast_imperative/entrypoints_length_limit.ml @@ -11,7 +11,7 @@ end open Errors let peephole_type_expression : type_expression -> type_expression result = fun e -> - let return type_content = ok { e with type_content } in + let return type_content = ok {type_content } in match e.type_content with | T_sum cmap -> let%bind _uu = bind_map_cmapi diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index f70b21aaf..c0af289dc 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -51,6 +51,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self init' record in ok res ) + | E_tuple t -> ( + let aux init'' expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_list aux (init') t in + ok res + ) + | E_tuple_update {tuple;update} -> ( + let%bind res = self init' tuple in + let%bind res = fold_expression self res update in + ok res + ) + | E_tuple_accessor {tuple} -> ( + let%bind res = self init' tuple in + ok res + ) | E_let_in { let_binder = _ ; rhs ; let_result } -> ( let%bind res = self init' rhs in let%bind res = self res let_result in @@ -161,6 +178,19 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind update = self update in return @@ E_record_update {record;path;update} ) + | E_tuple t -> ( + let%bind t' = bind_map_list self t in + return @@ E_tuple t' + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind tuple = self tuple in + let%bind update = self update in + return @@ E_tuple_update {tuple; path; update} + ) + | E_tuple_accessor {tuple;path} -> ( + let%bind tuple = self tuple in + return @@ E_tuple_accessor {tuple;path} + ) | E_constructor c -> ( let%bind e' = self c.element in return @@ E_constructor {c with element = e'} @@ -212,7 +242,7 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> let self = map_type_expression f in let%bind te' = f te in - let return type_content = ok { te' with type_content } in + let return type_content = ok { type_content } in match te'.type_content with | T_sum temap -> let%bind temap' = bind_map_cmap self temap in @@ -220,6 +250,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re | T_record temap -> let%bind temap' = bind_map_lmap self temap in return @@ (T_record temap') + | T_tuple telst -> + let%bind telst' = bind_map_list self telst in + return @@ (T_tuple telst') | T_arrow {type1 ; type2} -> let%bind type1' = self type1 in let%bind type2' = self type2 in @@ -324,6 +357,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, update) = self res update in ok (res, return @@ E_record_update {record;path;update}) ) + | E_tuple t -> ( + let%bind (res, t') = bind_fold_map_list self init' t in + ok (res, return @@ E_tuple t') + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind (res, tuple) = self init' tuple in + let%bind (res, update) = self res update in + ok (res, return @@ E_tuple_update {tuple;path;update}) + ) + | E_tuple_accessor {tuple; path} -> ( + let%bind (res, tuple) = self init' tuple in + ok (res, return @@ E_tuple_accessor {tuple; path}) + ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 7b214a2aa..89e5d99fb 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -123,6 +123,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result ) record in return @@ O.T_record (O.LMap.of_list record) + | I.T_tuple tuple -> + let%bind tuple = bind_map_list compile_type_expression tuple in + return @@ O.T_tuple tuple | I.T_arrow {type1;type2} -> let%bind type1 = compile_type_expression type1 in let%bind type2 = compile_type_expression type2 in @@ -154,9 +157,6 @@ and compile_type_operator : I.type_operator -> O.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in ok @@ O.TC_big_map (k,v) - | TC_map_or_big_map (k,v) -> - let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in - ok @@ O.TC_map_or_big_map (k,v) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in ok @@ O.TC_arrow (i,o) @@ -202,9 +202,9 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {record;label} -> + | I.E_record_accessor {record;path} -> let%bind record = compile_expression record in - return @@ O.E_record_accessor {record;label} + return @@ O.E_record_accessor {record;path} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in @@ -239,6 +239,16 @@ let rec compile_expression : I.expression -> O.expression result = let%bind expr2 = compile_expression expr2 in ok @@ add_to_end expr1 expr2 | I.E_skip -> return @@ O.E_skip + | I.E_tuple tuple -> + let%bind tuple = bind_map_list compile_expression tuple in + return @@ O.E_tuple (tuple) + | I.E_tuple_accessor {tuple;path} -> + let%bind tuple = compile_expression tuple in + return @@ O.E_tuple_accessor {tuple;path} + | I.E_tuple_update {tuple;path;update} -> + let%bind tuple = compile_expression tuple in + let%bind update = compile_expression update in + return @@ O.E_tuple_update {tuple;path;update} | I.E_assign ass -> let%bind content = compile_assign ass @@ O.e_skip () in return @@ content @@ -282,7 +292,6 @@ and compile_assign {variable; access_path; expression} expr = let%bind rhs = rhs @@ expression in ok @@ O.E_let_in {let_binder=(variable,None); mut=true; rhs; let_result=expr;inline = false} - and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> let%bind input_type = bind_map_option compile_type_expression input_type in @@ -541,6 +550,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul ) record in return @@ I.T_record (O.LMap.of_list record) + | O.T_tuple tuple -> + let%bind tuple = bind_map_list uncompile_type_expression tuple in + return @@ I.T_tuple tuple | O.T_arrow {type1;type2} -> let%bind type1 = uncompile_type_expression type1 in let%bind type2 = uncompile_type_expression type2 in @@ -572,9 +584,6 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in ok @@ I.TC_big_map (k,v) - | TC_map_or_big_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_map_or_big_map (k,v) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in ok @@ I.TC_arrow (i,o) @@ -621,13 +630,23 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {record;label} -> + | O.E_record_accessor {record;path} -> let%bind record = uncompile_expression record in - return @@ I.E_record_accessor {record;label} + return @@ I.E_record_accessor {record;path} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in return @@ I.E_record_update {record;path;update} + | O.E_tuple tuple -> + let%bind tuple = bind_map_list uncompile_expression tuple in + return @@ I.E_tuple tuple + | O.E_tuple_accessor {tuple;path} -> + let%bind tuple = uncompile_expression tuple in + return @@ I.E_tuple_accessor {tuple;path} + | O.E_tuple_update {tuple;path;update} -> + let%bind tuple = uncompile_expression tuple in + let%bind update = uncompile_expression update in + return @@ I.E_tuple_update {tuple;path;update} | O.E_map map -> let%bind map = bind_map_list ( bind_map_pair uncompile_expression diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 0e0ddbd45..46b9e4cfd 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -63,6 +63,23 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in ok res + | E_tuple t -> ( + let aux init'' expr = + let%bind res = fold_expression self init'' expr in + ok res + in + let%bind res = bind_fold_list aux (init') t in + ok res + ) + | E_tuple_update {tuple;update} -> ( + let%bind res = self init' tuple in + let%bind res = fold_expression self res update in + ok res + ) + | E_tuple_accessor {tuple} -> ( + let%bind res = self init' tuple in + ok res + ) and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> @@ -176,12 +193,25 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} ) + | E_tuple t -> ( + let%bind t' = bind_map_list self t in + return @@ E_tuple t' + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind tuple = self tuple in + let%bind update = self update in + return @@ E_tuple_update {tuple; path; update} + ) + | E_tuple_accessor {tuple;path} -> ( + let%bind tuple = self tuple in + return @@ E_tuple_accessor {tuple;path} + ) | E_literal _ | E_variable _ | E_skip as e' -> return e' and map_type_expression : ty_exp_mapper -> type_expression -> type_expression result = fun f te -> let self = map_type_expression f in let%bind te' = f te in - let return type_content = ok { te' with type_content } in + let return type_content = ok { type_content } in match te'.type_content with | T_sum temap -> let%bind temap' = bind_map_cmap self temap in @@ -189,6 +219,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re | T_record temap -> let%bind temap' = bind_map_lmap self temap in return @@ (T_record temap') + | T_tuple telst -> + let%bind telst' = bind_map_list self telst in + return @@ (T_tuple telst') | T_arrow {type1 ; type2} -> let%bind type1' = self type1 in let%bind type2' = self type2 in @@ -293,6 +326,19 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res, update) = self res update in ok (res, return @@ E_record_update {record;path;update}) ) + | E_tuple t -> ( + let%bind (res, t') = bind_fold_map_list self init' t in + ok (res, return @@ E_tuple t') + ) + | E_tuple_update {tuple; path; update} -> ( + let%bind (res, tuple) = self init' tuple in + let%bind (res, update) = self res update in + ok (res, return @@ E_tuple_update {tuple;path;update}) + ) + | E_tuple_accessor {tuple; path} -> ( + let%bind (res, tuple) = self init' tuple in + ok (res, return @@ E_tuple_accessor {tuple; path}) + ) | E_constructor c -> ( let%bind (res,e') = self init' c.element in ok (res, return @@ E_constructor {c with element = e'}) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 986f1cc16..1d6270dcb 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -24,6 +24,13 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = ) record in return @@ O.T_record (O.LMap.of_list record) + | I.T_tuple tuple -> + let aux (i,acc) el = + let%bind el = idle_type_expression el in + ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in + let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in + let record = O.LMap.of_list lst in + return @@ O.T_record record | I.T_arrow {type1;type2} -> let%bind type1 = idle_type_expression type1 in let%bind type2 = idle_type_expression type2 in @@ -55,9 +62,6 @@ and idle_type_operator : I.type_operator -> O.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in ok @@ O.TC_big_map (k,v) - | TC_map_or_big_map (k,v) -> - let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in - ok @@ O.TC_map_or_big_map (k,v) | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair idle_type_expression (i,o) in ok @@ O.TC_arrow (i,o) @@ -104,9 +108,9 @@ let rec compile_expression : I.expression -> O.expression result = ) record in return @@ O.E_record (O.LMap.of_list record) - | I.E_record_accessor {record;label} -> + | I.E_record_accessor {record;path} -> let%bind record = compile_expression record in - return @@ O.E_record_accessor {record;label} + return @@ O.E_record_accessor {record;path} | I.E_record_update {record;path;update} -> let%bind record = compile_expression record in let%bind update = compile_expression update in @@ -155,6 +159,22 @@ let rec compile_expression : I.expression -> O.expression result = let%bind expr2 = compile_expression expr2 in return @@ O.E_let_in {let_binder=(Var.of_name "_", Some O.t_unit); rhs=expr1;let_result=expr2; inline=false} | I.E_skip -> ok @@ O.e_unit ~loc:e.location () + | I.E_tuple t -> + let aux (i,acc) el = + let%bind el = compile_expression el in + ok @@ (i+1,(O.Label (string_of_int i), el)::acc) in + let%bind (_, lst ) = bind_fold_list aux (0,[]) t in + let m = O.LMap.of_list lst in + return @@ O.E_record m + | I.E_tuple_accessor {tuple;path} -> + let%bind record = compile_expression tuple in + let path = O.Label (string_of_int path) in + return @@ O.E_record_accessor {record;path} + | I.E_tuple_update {tuple;path;update} -> + let%bind record = compile_expression tuple in + let path = O.Label (string_of_int path) in + let%bind update = compile_expression update in + return @@ O.E_record_update {record;path;update} and compile_lambda : I.lambda -> O.lambda result = fun {binder;input_type;output_type;result}-> @@ -261,9 +281,7 @@ and uncompile_type_operator : O.type_operator -> I.type_operator result = | TC_big_map (k,v) -> let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in ok @@ I.TC_big_map (k,v) - | TC_map_or_big_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_map_or_big_map (k,v) + | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled" | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair uncompile_type_expression (i,o) in ok @@ I.TC_arrow (i,o) @@ -314,9 +332,9 @@ let rec uncompile_expression : O.expression -> I.expression result = ) record in return @@ I.E_record (O.LMap.of_list record) - | O.E_record_accessor {record;label} -> + | O.E_record_accessor {record;path} -> let%bind record = uncompile_expression record in - return @@ I.E_record_accessor {record;label} + return @@ I.E_record_accessor {record;path} | O.E_record_update {record;path;update} -> let%bind record = uncompile_expression record in let%bind update = uncompile_expression update in diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index c1d4065a6..f9f6cf66a 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -455,10 +455,10 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - * | Some (T_constant ("address" , [])) -> return (E_literal (Literal_address s)) (t_address ()) * | _ -> return (E_literal (Literal_string s)) (t_string ()) * ) *) - | E_record_accessor {record;label} -> ( + | E_record_accessor {record;path} -> ( let%bind (base' , state') = type_expression e state record in - let wrapped = Wrap.access_label ~base:base'.type_expression ~label in - return_wrapped (E_record_accessor {record=base';label}) state' wrapped + let wrapped = Wrap.access_label ~base:base'.type_expression ~label:path in + return_wrapped (E_record_accessor {record=base';path}) state' wrapped ) (* Sum *) @@ -917,15 +917,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {record; label} -> + | E_record_accessor {record; path} -> let%bind r' = untype_expression record in - let Label s = label in - return (e_accessor r' s) + let Label s = path in + return (e_record_accessor r' s) | E_record_update {record; path; update} -> let%bind r' = untype_expression record in let%bind e = untype_expression update in let Label l = path in - return (e_update r' l e) + return (e_record_update r' l e) | E_matching {matchee;cases} -> let%bind ae' = untype_expression matchee in let%bind m' = untype_matching untype_expression cases in diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 73a91118a..96137dd56 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -454,7 +454,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression return (e_address s) (t_address ()) | E_literal (Literal_operation op) -> return (e_operation op) (t_operation ()) - | E_record_accessor {record;label} -> + | E_record_accessor {record;path} -> let%bind e' = type_expression' e record in let aux (prev:O.expression) (a:I.label) : O.expression result = let property = a in @@ -463,10 +463,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression generic_try (bad_record_access property ae prev.type_expression ae.location) @@ (fun () -> I.LMap.find property r_tv) in let location = ae.location in - ok @@ make_a_e ~location (E_record_accessor {record=prev; label=property}) tv e + ok @@ make_a_e ~location (E_record_accessor {record=prev; path=property}) tv e in let%bind ae = - trace (simple_info "accessing") @@ aux e' label in + trace (simple_info "accessing") @@ aux e' path in (* check type annotation of the final accessed element *) let%bind () = match tv_opt with @@ -787,15 +787,15 @@ let rec untype_expression (e:O.expression) : (I.expression) result = let%bind r' = bind_smap @@ Map.String.map untype_expression r in return (e_record r') - | E_record_accessor {record; label} -> + | E_record_accessor {record; path} -> let%bind r' = untype_expression record in - let Label s = label in - return (e_accessor r' s) + let Label s = path in + return (e_record_accessor r' s) | E_record_update {record=r; path=l; update=e} -> let%bind r' = untype_expression r in let%bind e = untype_expression e in let Label l = l in - return (e_update r' l e) + return (e_record_update r' l e) | E_matching {matchee;cases} -> let%bind ae' = untype_expression matchee in let%bind m' = untype_matching untype_expression cases in diff --git a/src/passes/9-self_ast_typed/helpers.ml b/src/passes/9-self_ast_typed/helpers.ml index 92e887282..e410786e9 100644 --- a/src/passes/9-self_ast_typed/helpers.ml +++ b/src/passes/9-self_ast_typed/helpers.ml @@ -91,9 +91,9 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> let%bind cases' = map_cases f cases in return @@ E_matching {matchee=e';cases=cases'} ) - | E_record_accessor acc -> ( - let%bind e' = self acc.record in - return @@ E_record_accessor {acc with record = e'} + | E_record_accessor {record; path} -> ( + let%bind record = self record in + return @@ E_record_accessor {record; path} ) | E_record m -> ( let%bind m' = bind_map_lmap self m in @@ -186,9 +186,9 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,cases') = fold_map_cases f res cases in ok (res, return @@ E_matching {matchee=e';cases=cases'}) ) - | E_record_accessor acc -> ( - let%bind (res, e') = self init' acc.record in - ok (res, return @@ E_record_accessor {acc with record = e'}) + | E_record_accessor {record; path} -> ( + let%bind (res, record) = self init' record in + ok (res, return @@ E_record_accessor {record; path}) ) | E_record m -> ( let%bind (res, lst') = bind_fold_map_list (fun res (k,e) -> let%bind (res,e) = self res e in ok (res,(k,e))) init' (LMap.to_kv_list m) in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 1c8a243ff..667da637d 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -4,11 +4,45 @@ open Format open PP_helpers include Stage_common.PP -include Ast_PP_type(Ast_imperative_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev +let rec type_expression' : + (formatter -> type_expression -> unit) + -> formatter + -> type_expression + -> unit = + fun f ppf te -> + match te.type_content with + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m + | T_tuple t -> fprintf ppf "%a" (list_sep_d f) t + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ + +and type_expression ppf (te : type_expression) : unit = + type_expression' type_expression ppf te + +and type_operator : + (formatter -> type_expression -> unit) + -> formatter + -> type_operator + -> unit = + fun f ppf to_ -> + let s = + match to_ with + | TC_option te -> Format.asprintf "option(%a)" f te + | TC_list te -> Format.asprintf "list(%a)" f te + | TC_set te -> Format.asprintf "set(%a)" f te + | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v + | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v + | TC_contract te -> Format.asprintf "Contract (%a)" f te + in + fprintf ppf "(TO_%s)" s let rec expression ppf (e : expression) = expression_content ppf e.expression_content @@ -27,8 +61,8 @@ and expression_content ppf (ec : expression_content) = c.arguments | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m - | E_record_accessor {record; label=l}-> - fprintf ppf "%a.%a" expression record label l + | E_record_accessor ra -> + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> @@ -66,6 +100,12 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" + | E_tuple t -> + fprintf ppf "%a" (list_sep_d expression) t + | E_tuple_accessor ta -> + fprintf ppf "%a.%d" expression ta.tuple ta.path + | E_tuple_update {tuple; path; update} -> + fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update | E_assign {variable; access_path; expression=e} -> fprintf ppf "%a%a := %a" expression_variable variable diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index e49f811b3..2dd149b8a 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -19,14 +19,9 @@ module Errors = struct end open Errors -let make_t type_content = {type_content; type_meta = ()} +let make_t type_content = {type_content} -let tuple_to_record lst = - let aux (i,acc) el = (i+1,(string_of_int i, el)::acc) in - let (_, lst ) = List.fold_left aux (0,[]) lst in - lst - let t_bool : type_expression = make_t @@ T_constant (TC_bool) let t_string : type_expression = make_t @@ T_constant (TC_string) let t_bytes : type_expression = make_t @@ T_constant (TC_bytes) @@ -51,8 +46,8 @@ let t_record m : type_expression = let lst = Map.String.to_kv_list m in t_record_ez lst -let t_pair (a , b) : type_expression = t_record_ez [("0",a) ; ("1",b)] -let t_tuple lst : type_expression = t_record_ez (tuple_to_record lst) +let t_tuple lst : type_expression = make_t @@ T_tuple lst +let t_pair (a , b) : type_expression = t_tuple [a; b] let ez_t_sum (lst:(string * type_expression) list) : type_expression = let aux prev (k, v) = CMap.add (Constructor k) v prev in @@ -118,7 +113,8 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_accessor ?loc a b = e_record_accessor ?loc a b let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_skip ?loc () = make_expr ?loc @@ E_skip @@ -151,11 +147,12 @@ let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} +let e_update ?loc record path update = e_record_update ?loc record path update -let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) +let e_tuple ?loc lst : expression = make_expr ?loc @@ E_tuple lst let e_pair ?loc a b : expression = e_tuple ?loc [a;b] let make_option_typed ?loc e t_opt = @@ -201,7 +198,7 @@ let e_ez_assign ?loc variable access_path expression = let get_e_accessor = fun t -> match t with - | E_record_accessor {record; label} -> ok (record , label) + | E_record_accessor {record; path} -> ok (record , path) | _ -> simple_fail "not an accessor" let assert_e_accessor = fun t -> @@ -210,14 +207,7 @@ let assert_e_accessor = fun t -> let get_e_pair = fun t -> match t with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> simple_fail "not a pair" - ) + | E_tuple [a ; b] -> ok (a , b) | _ -> simple_fail "not a pair" let get_e_list = fun t -> @@ -225,29 +215,15 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt - in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux - let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_tuple t -> ok @@ t | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) result = fun e -> match e.expression_content with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> fail @@ bad_kind "pair" e.location - ) + | E_tuple [a;b] -> ok @@ (a,b) | _ -> fail @@ bad_kind "pair" e.location let extract_list : expression -> (expression list) result = fun e -> diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml index 7a2615e04..1c37f1744 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | 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 () -> @@ -182,7 +202,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (_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_recursive _,_) + | (E_record_accessor _, _) | (E_tuple_accessor _, _) | (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _) | (E_skip, _) | (E_assign _, _) diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 480d612fb..ee69248ba 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -2,17 +2,31 @@ module Location = Simple_utils.Location -module Ast_imperative_parameter = struct - type type_meta = unit -end - include Stage_common.Types -(*include Ast_generic_type(Ast_core_parameter) -*) -include Ast_generic_type (Ast_imperative_parameter) +type type_content = + | T_sum of type_expression constructor_map + | T_record of type_expression label_map + | T_tuple of type_expression list + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator + +and arrow = {type1: type_expression; type2: type_expression} + +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_expression * type_expression + | TC_big_map of type_expression * type_expression + | TC_arrow of type_expression * type_expression + +and type_expression = {type_content: type_content} + -type inline = bool type program = declaration Location.wrap list and declaration = | Declaration_type of (type_variable * type_expression) @@ -22,7 +36,7 @@ and declaration = * an optional type annotation * a boolean indicating whether it should be inlined * an expression *) - | Declaration_constant of (expression_variable * type_expression option * inline * expression) + | Declaration_constant of (expression_variable * type_expression option * bool * expression) (* | Macro_declaration of macro_declaration *) and expression = {expression_content: expression_content; location: Location.t} @@ -41,13 +55,16 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription (* Sugar *) | E_sequence of sequence | E_skip + | E_tuple of expression list + | E_tuple_accessor of tuple_accessor + | E_tuple_update of tuple_update (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -89,9 +106,10 @@ and let_in = and constructor = {constructor: constructor'; element: expression} -and accessor = {record: expression; label: label} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} + -and update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = @@ -105,6 +123,9 @@ and sequence = { expr2: expression ; } +and tuple_accessor = {tuple: expression; path: int} +and tuple_update = {tuple: expression; path: int ; update: expression} + and assign = { variable : expression_variable; access_path : access list; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index ca4184aff..bb4d4f147 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -4,11 +4,41 @@ open Format open PP_helpers include Stage_common.PP -include Ast_PP_type(Ast_sugar_parameter) let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev +let rec type_expression' : + (formatter -> type_expression -> unit) + -> formatter + -> type_expression + -> unit = + fun f ppf te -> + match te.type_content with + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m + | T_tuple t -> fprintf ppf "%a" (list_sep_d f) t + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ + +and type_expression ppf (te : type_expression) : unit = + type_expression' type_expression ppf te + +and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit = + fun f ppf to_ -> + let s = + match to_ with + | TC_option te -> Format.asprintf "option(%a)" f te + | TC_list te -> Format.asprintf "list(%a)" f te + | TC_set te -> Format.asprintf "set(%a)" f te + | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v + | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v + | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v + | TC_contract te -> Format.asprintf "Contract (%a)" f te + in + fprintf ppf "(TO_%s)" s let rec expression ppf (e : expression) = expression_content ppf e.expression_content @@ -28,7 +58,7 @@ and expression_content ppf (ec : expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.record label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_map m -> @@ -69,6 +99,12 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation | E_skip -> fprintf ppf "skip" + | E_tuple t -> + fprintf ppf "%a" (list_sep_d expression) t + | E_tuple_accessor ta -> + fprintf ppf "%a.%d" expression ta.tuple ta.path + | E_tuple_update {tuple; path; update} -> + fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index d5099ab28..cc18739c2 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -19,7 +19,7 @@ module Errors = struct end open Errors -let make_t type_content = {type_content; type_meta = ()} +let make_t type_content = {type_content} let tuple_to_record lst = @@ -112,6 +112,8 @@ let e_none ?loc () : expression = make_expr ?loc @@ E_constant {cons_name = C_NO let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_let_in ?loc (binder, ascr) mut inline rhs let_result = make_expr ?loc @@ E_let_in { let_binder = (binder, ascr) ; rhs ; let_result; inline; mut } @@ -127,6 +129,7 @@ let e_list ?loc lst : expression = make_expr ?loc @@ E_list lst let e_set ?loc lst : expression = make_expr ?loc @@ E_set lst let e_map ?loc lst : expression = make_expr ?loc @@ E_map lst let e_big_map ?loc lst : expression = make_expr ?loc @@ E_big_map lst +let e_look_up ?loc a b : expression = make_expr ?loc @@ E_look_up (a,b) let ez_match_variant (lst : ((string * string) * 'a) list) = let lst = List.map (fun ((c,n),a) -> ((Constructor c, Var.of_name n), a) ) lst in @@ -139,7 +142,7 @@ let e_record_ez ?loc (lst : (string * expr) list) : expression = let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst -let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path= Label b} let e_record_update ?loc record path update = let path = Label path in @@ -180,25 +183,18 @@ let e_lambda ?loc (binder : expression_variable) } let e_recursive ?loc fun_name fun_type lambda = make_expr ?loc @@ E_recursive {fun_name; fun_type; lambda} -let get_e_accessor = fun t -> +let get_e_record_accessor = fun t -> match t with - | E_record_accessor {record; label} -> ok (record , label) - | _ -> simple_fail "not an accessor" + | E_record_accessor {record; path} -> ok (record, path) + | _ -> simple_fail "not a record accessor" let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in + let%bind _ = get_e_record_accessor t in ok () let get_e_pair = fun t -> match t with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> simple_fail "not a pair" - ) + | E_tuple [a ; b] -> ok (a , b) | _ -> simple_fail "not a pair" let get_e_list = fun t -> @@ -206,29 +202,15 @@ let get_e_list = fun t -> | E_list lst -> ok lst | _ -> simple_fail "not a list" -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt - in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux - let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_tuple t -> ok @@ t | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) let extract_pair : expression -> (expression * expression) result = fun e -> match e.expression_content with - | E_record r -> ( - let lst = LMap.to_kv_list r in - match lst with - | [(Label "O",a);(Label "1",b)] - | [(Label "1",b);(Label "0",a)] -> - ok (a , b) - | _ -> fail @@ bad_kind "pair" e.location - ) + | E_tuple [a;b] -> ok @@ (a,b) | _ -> fail @@ bad_kind "pair" e.location let extract_list : expression -> (expression list) result = fun e -> diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index d790512f6..a8d7b5919 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -80,6 +80,7 @@ val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option val e_record : ?loc:Location.t -> expr Map.String.t -> expression val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_record_accessor : ?loc:Location.t -> expression -> string -> expression +val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression @@ -90,9 +91,11 @@ val e_list : ?loc:Location.t -> expression list -> expression val e_set : ?loc:Location.t -> expression list -> expression val e_map : ?loc:Location.t -> ( expression * expression ) list -> expression val e_big_map : ?loc:Location.t -> ( expr * expr ) list -> expression +val e_look_up : ?loc:Location.t -> expression -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression +val ez_match_variant : ((string * string ) * 'a ) list -> ('a,unit) matching_content val e_matching_variant : ?loc:Location.t -> expression -> ((string * string) * expression) list -> expression val make_option_typed : ?loc:Location.t -> expression -> type_expression option -> expression @@ -109,9 +112,6 @@ val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_tuple : ?loc:Location.t -> expression list -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression -(* -val get_e_accessor : expression' -> ( expression * access_path ) result -*) val assert_e_accessor : expression_content -> unit result diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml index 324529525..2d43bf2a9 100644 --- a/src/stages/2-ast_sugar/misc.ml +++ b/src/stages/2-ast_sugar/misc.ml @@ -140,6 +140,26 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | 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 () -> @@ -182,7 +202,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (_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_recursive _,_) + | (E_record_accessor _, _) | (E_tuple_accessor _, _) | (E_look_up _, _) | (E_matching _, _) | (E_sequence _, _) | (E_skip, _) -> simple_fail "comparing not a value" diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 5ad052e46..f4650284c 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -2,17 +2,31 @@ module Location = Simple_utils.Location -module Ast_sugar_parameter = struct - type type_meta = unit -end - include Stage_common.Types -(*include Ast_generic_type(Ast_core_parameter) -*) -include Ast_generic_type (Ast_sugar_parameter) +type type_content = + | T_sum of type_expression constructor_map + | T_record of type_expression label_map + | T_tuple of type_expression list + | T_arrow of arrow + | T_variable of type_variable + | T_constant of type_constant + | T_operator of type_operator + +and arrow = {type1: type_expression; type2: type_expression} + +and type_operator = + | TC_contract of type_expression + | TC_option of type_expression + | TC_list of type_expression + | TC_set of type_expression + | TC_map of type_expression * type_expression + | TC_big_map of type_expression * type_expression + | TC_arrow of type_expression * type_expression + +and type_expression = {type_content: type_content} + -type inline = bool type program = declaration Location.wrap list and declaration = | Declaration_type of (type_variable * type_expression) @@ -22,7 +36,7 @@ and declaration = * an optional type annotation * a boolean indicating whether it should be inlined * an expression *) - | Declaration_constant of (expression_variable * type_expression option * inline * expression) + | Declaration_constant of (expression_variable * type_expression option * bool * expression) (* | Macro_declaration of macro_declaration *) and expression = {expression_content: expression_content; location: Location.t} @@ -41,13 +55,16 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription (* Sugar *) | E_sequence of sequence | E_skip + | E_tuple of expression list + | E_tuple_accessor of tuple_accessor + | E_tuple_update of tuple_update (* Data Structures *) | E_map of (expression * expression) list | E_big_map of (expression * expression) list @@ -86,9 +103,8 @@ and let_in = { and constructor = {constructor: constructor'; element: expression} -and accessor = {record: expression; label: label} - -and update = {record: expression; path: label ; update: expression} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = @@ -102,6 +118,9 @@ and sequence = { expr2: expression ; } +and tuple_accessor = {tuple: expression; path: int} +and tuple_update = {tuple: expression; path: int ; update: expression} + and environment_element_definition = | ED_binder | ED_declaration of (expression * free_variables) diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 10ab7e9d4..2909d4dc8 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -28,7 +28,7 @@ and expression_content ppf (ec : expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.record label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_lambda {binder; input_type; output_type; result} -> diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index 787b61438..f5f5f103b 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -114,8 +114,8 @@ let e_map_add ?loc k v old : expression = make_expr ?loc @@ E_constant {cons_na let e_constructor ?loc s a : expression = make_expr ?loc @@ E_constructor { constructor = Constructor s; element = a} let e_matching ?loc a b : expression = make_expr ?loc @@ E_matching {matchee=a;cases=b} let e_matching_bool ?loc a b c : expression = e_matching ?loc a (Match_bool {match_true = b ; match_false = c}) -let e_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; label= Label b} -let e_accessor_list ?loc a b = List.fold_left (fun a b -> e_accessor ?loc a b) a b +let e_record_accessor ?loc a b = make_expr ?loc @@ E_record_accessor {record = a; path = Label b} +let e_record_accessor_list ?loc a b = List.fold_left (fun a b -> e_record_accessor ?loc a b) a b let e_variable ?loc v = make_expr ?loc @@ E_variable v let e_let_in ?loc (binder, ascr) inline rhs let_result = make_expr ?loc @@ E_let_in { let_binder = (binder,ascr) ; rhs ; let_result; inline } @@ -139,7 +139,7 @@ let e_record ?loc map = let lst = Map.String.to_kv_list map in e_record_ez ?loc lst -let e_update ?loc record path update = +let e_record_update ?loc record path update = let path = Label path in make_expr ?loc @@ E_record_update {record; path; update} @@ -178,20 +178,20 @@ let e_assign_with_let ?loc var access_path expr = | lst -> let rec aux path record= match path with | [] -> failwith "acces_path cannot be empty" - | [e] -> e_update ?loc record e expr + | [e] -> e_record_update ?loc record e expr | elem::tail -> - let next_record = e_accessor record elem in - e_update ?loc record elem (aux tail next_record ) + let next_record = e_record_accessor record elem in + e_record_update ?loc record elem (aux tail next_record ) in (var, None), true, (aux lst (e_variable var)), false -let get_e_accessor = fun t -> +let get_e_record_accessor = fun t -> match t with - | E_record_accessor {record; label} -> ok (record , label) + | E_record_accessor {record; path} -> ok (record, path) | _ -> simple_fail "not an accessor" -let assert_e_accessor = fun t -> - let%bind _ = get_e_accessor t in +let assert_e_record_accessor = fun t -> + let%bind _ = get_e_record_accessor t in ok () let get_e_pair = fun t -> @@ -218,16 +218,9 @@ let get_e_list = fun t -> in aux t -let tuple_of_record (m: _ LMap.t) = - let aux i = - let opt = LMap.find_opt (Label (string_of_int i)) m in - Option.bind (fun opt -> Some (opt,i+1)) opt - in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux - let get_e_tuple = fun t -> match t with - | E_record r -> ok @@ tuple_of_record r + | E_record r -> ok @@ List.map snd @@ Stage_common.Helpers.tuple_of_record r | _ -> simple_fail "ast_core: get_e_tuple: not a tuple" (* Same as get_e_pair *) diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 40a2a8496..e09ede186 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -76,8 +76,8 @@ val e_pair : ?loc:Location.t -> expression -> expression -> expression val e_constructor : ?loc:Location.t -> string -> expression -> expression val e_matching : ?loc:Location.t -> expression -> matching_expr -> expression val e_matching_bool : ?loc:Location.t -> expression -> expression -> expression -> expression -val e_accessor : ?loc:Location.t -> expression -> string -> expression -val e_accessor_list : ?loc:Location.t -> expression -> string list -> expression +val e_record_accessor : ?loc:Location.t -> expression -> string -> expression +val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> expression val e_variable : ?loc:Location.t -> expression_variable -> expression val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_let_in : ?loc:Location.t -> ( expression_variable * type_expression option ) -> bool -> expression -> expression -> expression @@ -95,14 +95,14 @@ val e_typed_none : ?loc:Location.t -> type_expression -> expression val e_lambda : ?loc:Location.t -> expression_variable -> type_expression option -> type_expression option -> expression -> expression val e_recursive : ?loc:Location.t -> expression_variable -> type_expression -> lambda -> expression val e_record : ?loc:Location.t -> expr Map.String.t -> expression -val e_update : ?loc:Location.t -> expression -> string -> expression -> expression +val e_record_update : ?loc:Location.t -> expression -> string -> expression -> expression val e_assign_with_let : ?loc:Location.t -> string -> string list -> expression -> ((expression_variable*type_expression option)*bool*expression*bool) (* val get_e_accessor : expression' -> ( expression * access_path ) result *) -val assert_e_accessor : expression_content -> unit result +val assert_e_record_accessor : expression_content -> unit result val get_e_pair : expression_content -> ( expression * expression ) result diff --git a/src/stages/3-ast_core/types.ml b/src/stages/3-ast_core/types.ml index ac59228c7..6c9637ac4 100644 --- a/src/stages/3-ast_core/types.ml +++ b/src/stages/3-ast_core/types.ml @@ -41,8 +41,8 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update (* Advanced *) | E_ascription of ascription @@ -75,9 +75,8 @@ and let_in = and constructor = {constructor: constructor'; element: expression} -and accessor = {record: expression; label: label} - -and update = {record: expression; path: label ; update: expression} +and record_accessor = {record: expression; path: label} +and record_update = {record: expression; path: label ; update: expression} and matching_expr = (expr,unit) matching_content and matching = diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 7461dd7de..0f1722641 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -29,7 +29,7 @@ and expression_content ppf (ec: expression_content) = | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.record label ra.label + fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update | E_lambda {binder; result} -> diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 8a399bb35..8f4aaac2a 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -335,7 +335,7 @@ let get_a_bool (t:expression) = let get_a_record_accessor = fun t -> match t.expression_content with - | E_record_accessor {record ; label} -> ok (record , label) + | E_record_accessor {record; path} -> ok (record, path) | _ -> simple_fail "not an accessor" let get_declaration_by_name : program -> string -> declaration result = fun p name -> diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index e5ef3dd36..b406c46b7 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -47,8 +47,8 @@ and expression_content = | E_matching of matching (* Record *) | E_record of expression label_map - | E_record_accessor of accessor - | E_record_update of update + | E_record_accessor of record_accessor + | E_record_update of record_update and constant = { cons_name: constant' @@ -84,12 +84,12 @@ and constructor = { element: expression ; } -and accessor = { +and record_accessor = { record: expression ; - label: label ; + path: label ; } -and update = { +and record_update = { record: expression ; path: label ; update: expression ; diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 559446668..832609b47 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -16,15 +16,14 @@ let cmap_sep value sep ppf m = let record_sep value sep ppf (m : 'a label_map) = let lst = LMap.to_kv_list m in - let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in + let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let tuple_sep value sep ppf m = assert (Helpers.is_tuple_lmap m); - let lst = LMap.to_kv_list m in - let lst = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (_k, v) = fprintf ppf "%a" value v in + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_, v) = fprintf ppf "%a" value v in fprintf ppf "%a" (list_sep new_pp sep) lst (* Prints records which only contain the consecutive fields @@ -156,43 +155,50 @@ let constant ppf : constant' -> unit = function let literal ppf (l : literal) = match l with - | Literal_unit -> - fprintf ppf "unit" - | Literal_void -> - fprintf ppf "void" - | Literal_bool b -> - fprintf ppf "%b" b - | Literal_int n -> - fprintf ppf "%d" n - | Literal_nat n -> - fprintf ppf "+%d" n - | Literal_timestamp n -> - fprintf ppf "+%d" n - | Literal_mutez n -> - fprintf ppf "%dmutez" n - | Literal_string s -> - fprintf ppf "%S" s - | Literal_bytes b -> - fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b) - | Literal_address s -> - fprintf ppf "@%S" s - | Literal_operation _ -> - fprintf ppf "Operation(...bytes)" - | Literal_key s -> - fprintf ppf "key %s" s - | Literal_key_hash s -> - fprintf ppf "key_hash %s" s - | Literal_signature s -> - fprintf ppf "Signature %s" s - | Literal_chain_id s -> - fprintf ppf "Chain_id %s" s + | Literal_unit -> fprintf ppf "unit" + | Literal_void -> fprintf ppf "void" + | Literal_bool b -> fprintf ppf "%b" b + | Literal_int n -> fprintf ppf "%d" n + | Literal_nat n -> fprintf ppf "+%d" n + | Literal_timestamp n -> fprintf ppf "+%d" n + | Literal_mutez n -> fprintf ppf "%dmutez" n + | Literal_string s -> fprintf ppf "%S" s + | Literal_bytes b -> fprintf ppf "0x%a" Hex.pp (Hex.of_bytes b) + | Literal_address s -> fprintf ppf "@%S" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" + | Literal_key s -> fprintf ppf "key %s" s + | Literal_key_hash s -> fprintf ppf "key_hash %s" s + | Literal_signature s -> fprintf ppf "Signature %s" s + | Literal_chain_id s -> fprintf ppf "Chain_id %s" s + +let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t + +and type_constant ppf (tc : type_constant) : unit = +let s = + match tc with + | TC_unit -> "unit" + | TC_string -> "string" + | TC_bytes -> "bytes" + | TC_nat -> "nat" + | TC_int -> "int" + | TC_mutez -> "mutez" + | TC_bool -> "bool" + | TC_operation -> "operation" + | TC_address -> "address" + | TC_key -> "key" + | TC_key_hash -> "key_hash" + | TC_signature -> "signature" + | TC_timestamp -> "timestamp" + | TC_chain_id -> "chain_id" + | TC_void -> "void" +in +fprintf ppf "%s" s + module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct module Agt=Ast_generic_type(PARAMETER) open Agt open Format - let type_variable ppf (t : type_variable) : unit = fprintf ppf "%a" Var.pp t - let rec type_expression' : (formatter -> type_expression -> unit) -> formatter @@ -200,58 +206,16 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct -> unit = fun f ppf te -> match te.type_content with - | T_sum m -> - fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> - fprintf ppf "%a" (tuple_or_record_sep_type f) m - | T_arrow a -> - fprintf ppf "%a -> %a" f a.type1 f a.type2 - | T_variable tv -> - type_variable ppf tv - | T_constant tc -> - type_constant ppf tc - | T_operator to_ -> - type_operator f ppf to_ + | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_variable tv -> type_variable ppf tv + | T_constant tc -> type_constant ppf tc + | T_operator to_ -> type_operator f ppf to_ and type_expression ppf (te : type_expression) : unit = type_expression' type_expression ppf te - and type_constant ppf (tc : type_constant) : unit = - let s = - match tc with - | TC_unit -> - "unit" - | TC_string -> - "string" - | TC_bytes -> - "bytes" - | TC_nat -> - "nat" - | TC_int -> - "int" - | TC_mutez -> - "mutez" - | TC_bool -> - "bool" - | TC_operation -> - "operation" - | TC_address -> - "address" - | TC_key -> - "key" - | TC_key_hash -> - "key_hash" - | TC_signature -> - "signature" - | TC_timestamp -> - "timestamp" - | TC_chain_id -> - "chain_id" - | TC_void -> - "void" - in - fprintf ppf "%s" s - and type_operator : (formatter -> type_expression -> unit) -> formatter diff --git a/src/stages/common/helpers.ml b/src/stages/common/helpers.ml index 5dba263b8..91cd0eae1 100644 --- a/src/stages/common/helpers.ml +++ b/src/stages/common/helpers.ml @@ -46,3 +46,23 @@ let get_pair m = match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with | Some e1, Some e2 -> ok (e1,e2) | _ -> simple_fail "not a pair" + +let tuple_of_record (m: _ LMap.t) = + let aux i = + let label = Label (string_of_int i) in + let opt = LMap.find_opt (label) m in + Option.bind (fun opt -> Some ((label,opt),i+1)) opt + in + Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + +let list_of_record_or_tuple (m: _ LMap.t) = + if (is_tuple_lmap m) then + List.map snd @@ tuple_of_record m + else + List.rev @@ LMap.to_list m + +let kv_list_of_record_or_tuple (m: _ LMap.t) = + if (is_tuple_lmap m) then + tuple_of_record m + else + List.rev @@ LMap.to_kv_list m diff --git a/src/stages/common/helpers.mli b/src/stages/common/helpers.mli index d5e388e36..1292bb807 100644 --- a/src/stages/common/helpers.mli +++ b/src/stages/common/helpers.mli @@ -1,3 +1,5 @@ +open Types + val bind_lmap : ('a * 'b list, 'c) result Types.label_map -> ('a Types.label_map * 'b list, 'c) result @@ -19,6 +21,9 @@ val is_tuple_lmap : 'a Types.label_map -> bool val get_pair : 'a Types.label_map -> (('a * 'a) * 'b list, unit -> Trace.error) result +val tuple_of_record : 'a LMap.t -> (label * 'a) list +val list_of_record_or_tuple : 'a LMap.t -> 'a list +val kv_list_of_record_or_tuple : 'a LMap.t -> (label * 'a) list diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index 545534b77..6b950eccd 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -136,7 +136,7 @@ module Substitution = struct and s_matching_expr : T.matching_expr w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_matching" - and s_accessor : T.accessor w = fun ~substs _ -> + and s_accessor : T.record_accessor w = fun ~substs _ -> let _TODO = substs in failwith "TODO: subst: unimplemented case s_access_path" @@ -182,10 +182,10 @@ module Substitution = struct * let val_ = s_expression ~v ~expr val_ in * ok @@ (key , val_)) aemap in * ok @@ T.E_record aemap *) - | T.E_record_accessor {record=e;label} -> + | T.E_record_accessor {record=e;path} -> let%bind record = s_expression ~substs e in - let%bind label = s_label ~substs label in - ok @@ T.E_record_accessor {record;label} + let%bind path = s_label ~substs path in + ok @@ T.E_record_accessor {record;path} | T.E_record_update {record;path;update}-> let%bind record = s_expression ~substs record in let%bind update = s_expression ~substs update in diff --git a/src/test/contracts/tuple.ligo b/src/test/contracts/tuple.ligo index afe953345..963d1aa51 100644 --- a/src/test/contracts/tuple.ligo +++ b/src/test/contracts/tuple.ligo @@ -13,6 +13,11 @@ const fb : foobar = (0,0) function projection (const tpl : foobar) : int is tpl.0 + tpl.1 -type big_tuple is int * int * int * int * int +type big_tuple is int * int * int * int * int * int * int * int * int * int * int * int -const br : big_tuple = (23, 23, 23, 23, 23) +const br : big_tuple = (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11) + +function update (const tpl : big_tuple) : big_tuple is + block { + tpl.11 := 2048 + } with tpl diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index 4006d6b79..c1929f55b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -876,9 +876,14 @@ let tuple () : unit result = expect_eq_n program "modify_abc" make_input make_expected in let%bind () = - let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in + let expected = ez [0 ; 1 ; 2 ; 3 ; 4; 5; 6; 7; 8; 9; 10; 11] in expect_eq_evaluate program "br" expected in + let%bind () = + let make_input = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; n] in + let make_expected = fun n -> ez [n; n; n; n; n; n; n; n; n; n; n; 2048] in + expect_eq_n program "update" make_input make_expected + in ok () let tuple_mligo () : unit result = From c9e509f636e94cd469bc29f825e5f6af75ccd170 Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Tue, 31 Mar 2020 16:41:56 +0200 Subject: [PATCH 4/8] review 1 --- dexter.ligo | 585 ++++++++++++++++++++++++++++++ src/stages/1-ast_imperative/PP.ml | 12 +- src/stages/2-ast_sugar/PP.ml | 14 +- 3 files changed, 598 insertions(+), 13 deletions(-) create mode 100644 dexter.ligo diff --git a/dexter.ligo b/dexter.ligo new file mode 100644 index 000000000..0af2bb11d --- /dev/null +++ b/dexter.ligo @@ -0,0 +1,585 @@ +// Dexter +// a decentralized Tezos exchange for XTZ and FA1.2 +// copyright: camlCase 2019-2020 +// version: 0.1.5.0 + +// ============================================================================= +// Entrypoints +// ============================================================================= + +type entrypoint is +| Approve of (address * nat * nat) +| AddLiquidity of (address * nat * nat * timestamp) +| RemoveLiquidity of (address * address * nat * tez * nat * timestamp) +| XtzToToken of (address * nat * timestamp) +| TokenToXtz of (address * address * nat * tez * timestamp) +| BetForBakingRights of (key_hash * address * nat) +| EndAuctionRound +| UpdateTokenBalance of (nat) + +// the transfer entrypoint of the FA1.2 contract +type token_contract_transfer is (address * address * nat); + +// ============================================================================= +// Storage +// ============================================================================= + +type baker_address is key_hash; + +type account is record + balance : nat; + allowances: map(address, nat); +end + +// this is just to force big_maps as the first item of a pair on the top +// so we can still use the old big map route without big map id for +// convenience +type s is record + current_baker: option(baker_address); + current_baker_candidate: option(baker_address * address * tez * nat); + last_auction: timestamp; + lqt_total: nat; + token_address: address; + token_balance: nat; + rewards: (tez * nat); +end + +type storage is record + s: s; + accounts: big_map(address, account); +end + +// ============================================================================= +// Constants +// ============================================================================= + +const empty_allowances : map(address,nat) = map end; + +const empty_ops : list(operation) = list end; + +const no_baker_candidate: option(baker_address * address * tez * nat) = None; + +const no_baker: option(key_hash) = None; + +// 21 days +// 86400 seconds * 21 +const dexter_cycle: int = 1814400; + +// ============================================================================= +// Helper Functions +// ============================================================================= + +function mutez_to_natural(const a: tez): nat is + block {skip} with a / 1mutez + +function natural_to_mutez(const a: nat): tez is + block {skip} with a * 1mutez + +// this will fail if provided a negative number +function int_to_nat(const error: string ; const a: int): nat is + block { + var result : nat := 0n; + if (a >= 0) then block { + result := abs(a); + } else block { + failwith(error) + }; + } with result; + +// get an account from the big_map, if one does not exist for a particular +// address then create one. +function get_account(const a: address ; const m: big_map(address, account)): account is + block { skip } with ( + case (m[a]) of + | None -> record balance = 0n; allowances = empty_allowances; end + | Some(account) -> account + end + ); + +function update_allowance(const owner : address; + const spender : address; + const updated_allowance: nat; + var storage : storage): + storage is + block { + if (spender =/= owner) then block { + var account: account := get_account(owner, storage.accounts); + account.allowances[spender] := updated_allowance; + storage.accounts[owner] := record balance = account.balance; allowances = account.allowances; end; + } else { + skip; + } + } with storage; + +// if sender is owner, return amount, otherwise check if sender has permission +// if true then return amount, otherwise fail +function get_sender_allowance(const owner: address ; const storage: storage): nat is + block { + var result: nat := 0n; + case storage.accounts[owner] of + | None -> failwith("2") + | Some(account) -> block { + if sender =/= owner then block { + case account.allowances[sender] of + | None -> failwith("3") + | Some(allowance) -> result := allowance + end; + } else block { + result := account.balance + } + } + end; + } with result; + +function get_current_candidate_bet (const storage: storage): (tez * nat) is + block { + var current_candidate_bet: (tez * nat) := (0mutez, 0n); + case (storage.s.current_baker_candidate) of + | None -> skip + | Some(current_baker_candidate) -> current_candidate_bet := (current_baker_candidate.2, current_baker_candidate.3) + end + } with current_candidate_bet; + +// there might be some zero division edge cases +function get_xtz_pool (const current_candidate_bet_xtz: tez ; const storage: storage): (tez) is + block { + const time_since_last_auction: int = now - storage.s.last_auction; + const days_since_last_auction: int = time_since_last_auction / 86400; + var xtz_pool : tez := 0mutez; + + if (days_since_last_auction < dexter_cycle) then block { + const released_rewards : tez = (storage.s.rewards.0 / abs((days_since_last_auction * 1000 / dexter_cycle))) / 1000n; + const unreleased_rewards: tez = storage.s.rewards.0 - released_rewards; + + xtz_pool := balance - current_candidate_bet_xtz - unreleased_rewards - amount; + } else block { + // the slow reward wait has passed, all the rewards are released + + xtz_pool := balance - current_candidate_bet_xtz - amount; + }; + } with xtz_pool; + +// there might be some zero division edge cases +function get_token_pool (const current_candidate_bet_token: nat ; const storage: storage): (nat) is + block { + const time_since_last_auction: int = now - storage.s.last_auction; + const days_since_last_auction: int = time_since_last_auction / 86400; + var token_pool : nat := 0n; + + if (days_since_last_auction < dexter_cycle) then block { + const reward_days : int = days_since_last_auction; + const released_rewards : nat = (storage.s.rewards.1 / abs((reward_days * 1000 / dexter_cycle))) / 1000n; + const unreleased_rewards: nat = abs(storage.s.rewards.1 - released_rewards); + + token_pool := abs(storage.s.token_balance - current_candidate_bet_token - unreleased_rewards); + } else block { + // the slow reward wait has passed, all the rewards are released + token_pool := abs(storage.s.token_balance - current_candidate_bet_token) + }; + } with token_pool; + +// ============================================================================= +// Entrypoint Functions +// ============================================================================= + +function approve(const spender : address; + const allowance: nat; + const current_allowance: nat; + var storage : storage): + (list(operation) * storage) is + block { + if (spender =/= sender) then block { + // get the sender's account + // if the account does not exist, fail, we do not want to create accounts here + // creating accounts should be done in add_liquidity + const account: account = get_account(sender, storage.accounts); + + var sender_allowances: map(address, nat) := account.allowances; + sender_allowances[spender] := allowance; + storage.accounts[sender] := record balance = account.balance; allowances = sender_allowances; end; + } else block { + failwith("1"); + } + } with (empty_ops, storage); + +// it is assumed that the exchange contract has permission from the FA1.2 token +// to manage the assets of the user. It is the responsibility of the dApp +// developer to handle permissions. +function add_liquidity(const owner : address; + const min_lqt_created : nat; + const max_tokens_deposited: nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + // add_liquidity performs a transfer to the token contract, we need to + // return the operations + var op_list: list(operation) := nil; + + if (now < deadline) then skip else block { + failwith("4"); + }; + + if (max_tokens_deposited > 0n) then skip else block { + failwith("5"); + }; + + if (amount > 0mutez) then skip else block { + failwith("6"); + }; + + if (storage.s.lqt_total > 0n) then block { + // lqt_total greater than zero + // use the existing exchange rate + + if (min_lqt_created > 0n) then skip else block { + failwith("7"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const nat_amount : nat = mutez_to_natural(amount); + const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; + const lqt_minted : nat = nat_amount * storage.s.lqt_total / xtz_pool; + + if (max_tokens_deposited >= tokens_deposited) then skip else block { + failwith("8"); + }; + + if (lqt_minted >= min_lqt_created) then skip else block { + failwith("9"); + }; + + const account: account = get_account(owner, storage.accounts); + const new_balance: nat = account.balance + lqt_minted; + storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; + storage.s.lqt_total := storage.s.lqt_total + lqt_minted; + storage.s.token_balance := storage.s.token_balance + tokens_deposited; + + // send FA1.2 from owner to exchange + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); + op_list := list op1; end; + + } else block { + // initial add liquidity + if (amount >= 1tz) then skip else block { + failwith("10"); + }; + + const tokens_deposited : nat = max_tokens_deposited; + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const initial_liquidity : nat = mutez_to_natural(balance - current_candidate_bet.0); + + storage.s.lqt_total := initial_liquidity; + storage.accounts[owner] := record balance = initial_liquidity; allowances = empty_allowances; end; + storage.s.token_balance := tokens_deposited; + + // send FA1.2 tokens from owner to exchange + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); + op_list := list op1; end; + } + } with (op_list, storage); + +function remove_liquidity(const owner : address; + const to_ : address; + const lqt_burned : nat; + const min_xtz_withdrawn : tez; + const min_tokens_withdrawn : nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("11"); + }; + + if (min_xtz_withdrawn > 0mutez) then skip else block { + failwith("12"); + }; + + if (min_tokens_withdrawn > 0n) then skip else block { + failwith("13"); + }; + + if (lqt_burned > 0n) then skip else block { + failwith("14"); + }; + + // returns total if sender is owner, otherwise looks it up + const lqt: nat = get_sender_allowance(owner, storage); + + if (lqt >= lqt_burned) then skip else block { + failwith("15"); + }; + + if (storage.s.lqt_total > 0n) then skip else block { + failwith("16"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_withdrawn : tez = natural_to_mutez(lqt_burned * mutez_to_natural(balance - current_candidate_bet.0) / storage.s.lqt_total); + + if (xtz_withdrawn >= min_xtz_withdrawn) then skip else block { + failwith("17"); + }; + + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const tokens_withdrawn: nat = lqt_burned * token_pool / storage.s.lqt_total; + + if (tokens_withdrawn >= min_tokens_withdrawn) then skip else block { + failwith("18"); + }; + + const account: account = get_account(owner, storage.accounts); + + if (account.balance >= lqt_burned) then skip else block { + failwith("19"); + }; + + const new_balance: nat = int_to_nat("33", account.balance - lqt_burned); + storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; + + storage.s.lqt_total := int_to_nat("34", storage.s.lqt_total - lqt_burned); + storage.s.token_balance := int_to_nat("35", storage.s.token_balance - tokens_withdrawn); + + // update allowance + // lqt - lqt_burned is safe, we have already checed that lqt >= lqt_burned + storage := update_allowance(owner, sender, int_to_nat("36", lqt - lqt_burned), storage); + + // send xtz_withdrawn to to_ address + const to_contract: contract(unit) = get_contract(to_); + const op1: operation = transaction(unit, xtz_withdrawn, to_contract); + + // send tokens_withdrawn to to address + // if tokens_withdrawn if greater than storage.s.token_balance, this will fail + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op2: operation = transaction((self_address, to_, tokens_withdrawn), 0mutez, token_contract); + op_list := list op1; op2; end + } with (op_list, storage); + +function xtz_to_token(const to_ : address; + const min_tokens_bought: nat; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("20"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const nat_amount : nat = mutez_to_natural(amount); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const tokens_bought : nat = (nat_amount * 997n * token_pool) / (xtz_pool * 1000n + (nat_amount * 997n)); + + if (tokens_bought >= min_tokens_bought) then skip else block { + failwith("21"); + }; + + storage.s.token_balance := int_to_nat("32", storage.s.token_balance - tokens_bought); + + // send tokens_withdrawn to to address + // if tokens_bought is greater than storage.s.token_balance, this will fail + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op: operation = transaction((self_address, to_, tokens_bought), 0mutez, token_contract); + + // append internal operations + op_list := list op; end; + } with (op_list, storage); + +function token_to_xtz(const owner : address; // the address of the owner of FA1.2 + const to_ : address; + const tokens_sold : nat; + const min_xtz_bought: tez; + const deadline : timestamp; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (now < deadline) then skip else block { + failwith("22"); + }; + + const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); + const xtz_pool : tez = get_xtz_pool(current_candidate_bet.0, storage); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const xtz_bought : tez = natural_to_mutez((tokens_sold * 997n * mutez_to_natural(xtz_pool)) / (token_pool * 1000n + (tokens_sold * 997n))); + + if (xtz_bought >= min_xtz_bought) then skip else block { + failwith("23"); + }; + + storage.s.token_balance := storage.s.token_balance + tokens_sold; + + // send xtz_bought to to_ address + const to_contract: contract(unit) = get_contract(to_); + const op1: operation = transaction(unit, xtz_bought, to_contract); + + // send tokens_sold to the exchange address + // this assumes that the exchange has an allowance for the token and owner in FA1.2 + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const op2: operation = transaction((owner, self_address, tokens_sold), 0mutez, token_contract); + + // append internal operations + op_list := list op1; op2; end; + } with (op_list, storage); + +function assert_valid_baker (const current_baker: option(key_hash); + const candidate: key_hash): (operation * operation) is + block { + // test the candidate baker, if it is valid this will not fail + const test_set_delegate_operation: operation = set_delegate(Some(candidate)); + + // reset to the current baker + const reset_set_delegate_operation: operation = set_delegate(current_baker); + } with (test_set_delegate_operation, reset_set_delegate_operation); + +function bet_for_baking_rights (const candidate : key_hash; + const token_source : address; + const max_tokens_bet : nat; + var storage : storage): + (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + + // this is a trick to assert that the provided baker address is valid + case (storage.s.current_baker_candidate) of + | None -> block { + const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); + op_list := op_pair.0 # op_list; + op_list := op_pair.1 # op_list; + } + | Some(current_baker_candidate) -> block { + if (current_baker_candidate.0 = candidate) then skip else block { + const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); + op_list := op_pair.0 # op_list; + op_list := op_pair.1 # op_list; + }; + } + end; + + // now we are sure it is a valid baker + + // set a minimum bet + if (max_tokens_bet > 0n) then skip else block { + failwith("24"); + }; + + if (amount > 0mutez) then skip else block { + failwith("25"); + }; + + const current_candidate_bet : (tez * nat) = get_current_candidate_bet(storage); + + if (amount > current_candidate_bet.0) then skip else { failwith("26") }; + + const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); + const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); + const nat_amount : nat = mutez_to_natural(amount); + const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; + + if (tokens_deposited > current_candidate_bet.1) then skip else { failwith("27") }; + if (tokens_deposited > max_tokens_bet) then skip else { failwith("28") }; + + case (storage.s.current_baker_candidate) of + | None -> block { + // add the tokens_deposited to the token_balance + storage.s.token_balance := storage.s.token_balance + tokens_deposited; + } + | Some(current_baker_candidate) -> block { + // return rejected candidates tez and tokens to previous candidate + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const return_token_op: operation = transaction((self_address, current_baker_candidate.1, current_baker_candidate.3), 0mutez, token_contract); + op_list := return_token_op # op_list; + + const to_contract: contract(unit) = get_contract(current_baker_candidate.1); + const return_xtz_op: operation = transaction(unit, current_baker_candidate.2, to_contract); + op_list := return_xtz_op # op_list; + + // remove the tokens from the current_baker_candidate + // add the tokens_deposited to the token_balance + storage.s.token_balance := abs(storage.s.token_balance - current_baker_candidate.3) + tokens_deposited; + } + end; + + storage.s.current_baker_candidate := Some((candidate,token_source,amount,tokens_deposited)); + + // send FA1.2 from owner to exchange, dexter needs permission to transfer these tokens + const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); + const xtz_to_dexter_op: operation = transaction((token_source, self_address, tokens_deposited), 0mutez, token_contract); + op_list := xtz_to_dexter_op # op_list; + + } with (op_list, storage); + +function end_auction_round(var storage : storage) : (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + // 604800 seconds is one week + if (now > storage.s.last_auction + 604800) then skip else {failwith("29")}; + + case (storage.s.current_baker_candidate) of + | None -> block { + const set_delegate_op: operation = set_delegate(no_baker); + op_list := set_delegate_op # op_list; + } + | Some(current_baker_candidate) -> block { + case (storage.s.current_baker) of + | None -> block { + storage.s.current_baker := Some(current_baker_candidate.0); + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + const set_delegate_op: operation = set_delegate(storage.s.current_baker); + op_list := set_delegate_op # op_list; + } + | Some(current_baker) -> block { + if (current_baker = current_baker_candidate.0) then block { + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + } else { + storage.s.current_baker := Some(current_baker_candidate.0); + storage.s.current_baker_candidate := no_baker_candidate; + storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; + storage.s.last_auction := now; + const set_delegate_op: operation = set_delegate(storage.s.current_baker); + op_list := set_delegate_op # op_list; + } + } + end; + } + end; + + } with (op_list, storage); + +function update_token_balance(const token_balance: nat ; var storage : storage) : (list(operation) * storage) is + block { + var op_list: list(operation) := nil; + if (sender =/= storage.s.token_address) then { + failwith("31"); + } else { + storage.s.token_balance := token_balance; + } + } with (op_list, storage); + +// ============================================================================= +// Main +// ============================================================================= + +function main (const entrypoint : entrypoint ; const storage : storage) : (list(operation) * storage) is + (case entrypoint of + | Approve(xs) -> approve(xs.0,xs.1,xs.2,storage) + | AddLiquidity(xs) -> add_liquidity(xs.0,xs.1,xs.2,xs.3,storage) + | RemoveLiquidity(xs) -> remove_liquidity(xs.0,xs.1,xs.2,xs.3,xs.4,xs.5,storage) + | XtzToToken(xs) -> xtz_to_token(xs.0,xs.1,xs.2,storage) + | TokenToXtz(xs) -> token_to_xtz(xs.0,xs.1,xs.2,xs.3,xs.4,storage) + | BetForBakingRights(xs) -> bet_for_baking_rights(xs.0,xs.1,xs.2,storage) + | EndAuctionRound -> end_auction_round(storage) + | UpdateTokenBalance(xs) -> update_token_balance(xs, storage) + end); diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 667da637d..2e8ff28a1 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -16,8 +16,8 @@ let rec type_expression' : fun f ppf te -> match te.type_content with | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m - | T_tuple t -> fprintf ppf "%a" (list_sep_d f) t + | T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m + | T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_variable tv -> type_variable ppf tv | T_constant tc -> type_constant ppf tc @@ -60,11 +60,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> - fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + fprintf ppf "{%a}" (record_sep expression (const ";")) m | E_record_accessor ra -> fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> - fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + fprintf ppf "{ %a with %a = %a }" expression record label path expression update | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m | E_big_map m -> @@ -101,11 +101,11 @@ and expression_content ppf (ec : expression_content) = | E_skip -> fprintf ppf "skip" | E_tuple t -> - fprintf ppf "%a" (list_sep_d expression) t + fprintf ppf "(%a)" (list_sep_d expression) t | E_tuple_accessor ta -> fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> - fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update + fprintf ppf "{ %a with %d = %a }" expression tuple path expression update | E_assign {variable; access_path; expression=e} -> fprintf ppf "%a%a := %a" expression_variable variable diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index bb4d4f147..e2f86622e 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -16,9 +16,9 @@ let rec type_expression' : fun f ppf te -> match te.type_content with | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m - | T_tuple t -> fprintf ppf "%a" (list_sep_d f) t - | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 + | T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m + | T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t + | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_variable tv -> type_variable ppf tv | T_constant tc -> type_constant ppf tc | T_operator to_ -> type_operator f ppf to_ @@ -56,11 +56,11 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> - fprintf ppf "%a" (tuple_or_record_sep_expr expression) m + fprintf ppf "{%a}" (record_sep expression (const ";")) m | E_record_accessor ra -> fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> - fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + fprintf ppf "{ %a with %a = %a }" expression record label path expression update | E_map m -> fprintf ppf "map[%a]" (list_sep_d assoc_expression) m | E_big_map m -> @@ -100,11 +100,11 @@ and expression_content ppf (ec : expression_content) = | E_skip -> fprintf ppf "skip" | E_tuple t -> - fprintf ppf "%a" (list_sep_d expression) t + fprintf ppf "(%a)" (list_sep_d expression) t | E_tuple_accessor ta -> fprintf ppf "%a.%d" expression ta.tuple ta.path | E_tuple_update {tuple; path; update} -> - fprintf ppf "{ %a with { %d = %a } }" expression tuple path expression update + fprintf ppf "{ %a with %d = %a }" expression tuple path expression update and option_type_name ppf ((n, ty_opt) : expression_variable * type_expression option) = From 9dc7e7fcb9a2469c0dba28d6b71e7ee8d437ff0b Mon Sep 17 00:00:00 2001 From: Pierre-Emmanuel Wulfman Date: Mon, 30 Mar 2020 14:38:18 +0200 Subject: [PATCH 5/8] Add E_cond as sugar (if .. then .. else ..) for match_bool --- src/passes/3-self_ast_imperative/helpers.ml | 15 +++++++++++ .../imperative_to_sugar.ml | 27 +++++++++++++++++++ src/passes/5-self_ast_sugar/helpers.ml | 15 +++++++++++ src/passes/6-sugar_to_core/sugar_to_core.ml | 5 ++++ src/stages/1-ast_imperative/PP.ml | 5 ++++ src/stages/1-ast_imperative/combinators.ml | 2 +- src/stages/1-ast_imperative/misc.ml | 3 ++- src/stages/1-ast_imperative/types.ml | 8 ++++++ src/stages/2-ast_sugar/PP.ml | 9 +++++-- src/stages/2-ast_sugar/combinators.ml | 2 +- src/stages/2-ast_sugar/combinators.mli | 2 +- src/stages/2-ast_sugar/misc.ml | 3 ++- src/stages/2-ast_sugar/types.ml | 7 +++++ 13 files changed, 96 insertions(+), 7 deletions(-) diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index c0af289dc..47626335f 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -76,6 +76,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini | E_recursive { lambda={result=e;_}; _} -> let%bind res = self init' e in ok res + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res | E_sequence {expr1;expr2} -> let ab = (expr1,expr2) in let%bind res = bind_fold_pair self init' ab in @@ -217,6 +222,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} | E_sequence {expr1;expr2} -> ( let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} @@ -396,6 +406,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) | E_sequence {expr1;expr2} -> ( let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in ok (res, return @@ E_sequence {expr1;expr2}) diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 89e5d99fb..4a69e6c67 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -234,6 +234,28 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = compile_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_cond {condition;then_clause;else_clause} -> + let%bind condition = compile_expression condition in + let%bind then_clause' = compile_expression then_clause in + let%bind else_clause' = compile_expression else_clause in + let env = Var.fresh () in + let%bind ((_,free_vars_true), then_clause) = repair_mutable_variable_in_matching then_clause' [] env in + let%bind ((_,free_vars_false), else_clause) = repair_mutable_variable_in_matching else_clause' [] env in + let then_clause = add_to_end then_clause (O.e_variable env) in + let else_clause = add_to_end else_clause (O.e_variable env) in + + let free_vars = List.sort_uniq Var.compare @@ free_vars_true @ free_vars_false in + if (List.length free_vars != 0) then + let cond_expr = O.e_cond condition then_clause else_clause in + let return_expr = fun expr -> + O.E_let_in {let_binder=(env,None); mut=false; inline=false;rhs=(store_mutable_variable free_vars); + let_result=O.e_let_in (env,None) false false cond_expr @@ + expr + } + in + return @@ restore_mutable_variable return_expr free_vars env + else + return @@ O.E_cond {condition; then_clause=then_clause'; else_clause=else_clause'} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in @@ -672,6 +694,11 @@ let rec uncompile_expression : O.expression -> I.expression result = let%bind anno_expr = uncompile_expression anno_expr in let%bind type_annotation = uncompile_type_expression type_annotation in return @@ I.E_ascription {anno_expr; type_annotation} + | O.E_cond {condition;then_clause;else_clause} -> + let%bind condition = uncompile_expression condition in + let%bind then_clause = uncompile_expression then_clause in + let%bind else_clause = uncompile_expression else_clause in + return @@ I.E_cond {condition; then_clause; else_clause} | O.E_sequence {expr1; expr2} -> let%bind expr1 = uncompile_expression expr1 in let%bind expr2 = uncompile_expression expr2 in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 46b9e4cfd..7ac208768 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -56,6 +56,11 @@ let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f ini let%bind res = self res let_result in ok res ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res = self init' condition in + let%bind res = self res then_clause in + let%bind res = self res else_clause in + ok res | E_recursive { lambda={result=e;_}; _} -> let%bind res = self init' e in ok res @@ -189,6 +194,11 @@ let rec map_expression : exp_mapper -> expression -> expression result = fun f e let%bind args = bind_map_list self c.arguments in return @@ E_constant {c with arguments=args} ) + | E_cond {condition; then_clause; else_clause} -> + let%bind condition = self condition in + let%bind then_clause = self then_clause in + let%bind else_clause = self else_clause in + return @@ E_cond {condition;then_clause;else_clause} | E_sequence {expr1;expr2} -> ( let%bind (expr1,expr2) = bind_map_pair self (expr1,expr2) in return @@ E_sequence {expr1;expr2} @@ -365,6 +375,11 @@ let rec fold_map_expression : 'a fold_mapper -> 'a -> expression -> ('a * expres let%bind (res,args) = bind_fold_map_list self init' c.arguments in ok (res, return @@ E_constant {c with arguments=args}) ) + | E_cond {condition; then_clause; else_clause} -> + let%bind res,condition = self init' condition in + let%bind res,then_clause = self res then_clause in + let%bind res,else_clause = self res else_clause in + ok (res, return @@ E_cond {condition;then_clause;else_clause}) | E_sequence {expr1;expr2} -> ( let%bind (res,(expr1,expr2)) = bind_fold_map_pair self init' (expr1,expr2) in ok (res, return @@ E_sequence {expr1;expr2}) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 1d6270dcb..b175f8eb3 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -154,6 +154,11 @@ let rec compile_expression : I.expression -> O.expression result = let%bind anno_expr = compile_expression anno_expr in let%bind type_annotation = idle_type_expression type_annotation in return @@ O.E_ascription {anno_expr; type_annotation} + | I.E_cond {condition; then_clause; else_clause} -> + let%bind matchee = compile_expression condition in + let%bind match_true = compile_expression then_clause in + let%bind match_false = compile_expression else_clause in + return @@ O.E_matching {matchee; cases=Match_bool{match_true;match_false}} | I.E_sequence {expr1; expr2} -> let%bind expr1 = compile_expression expr1 in let%bind expr2 = compile_expression expr2 in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 2e8ff28a1..a9ca9fe03 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -96,6 +96,11 @@ and expression_content ppf (ec : expression_content) = | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation + | E_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause | E_sequence {expr1;expr2} -> fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 2dd149b8a..a71f5268e 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -131,7 +131,7 @@ let e_while ?loc condition body = make_expr ?loc @@ E_while {condition; body} let e_for ?loc binder start final increment body = make_expr ?loc @@ E_for {binder;start;final;increment;body} let e_for_each ?loc binder collection collection_type body = make_expr ?loc @@ E_for_each {binder;collection;collection_type;body} -let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) +let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} (* let e_assign ?loc a b c = location_wrap ?loc @@ E_assign (Var.of_name a , b , c) (* TODO handlethat*) *) diff --git a/src/stages/1-ast_imperative/misc.ml b/src/stages/1-ast_imperative/misc.ml index 1c37f1744..884822fff 100644 --- a/src/stages/1-ast_imperative/misc.ml +++ b/src/stages/1-ast_imperative/misc.ml @@ -204,7 +204,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) + | (E_look_up _, _) + | (E_matching _, _) | (E_cond _, _) | (E_sequence _, _) | (E_skip, _) | (E_assign _, _) | (E_for _, _) | (E_for_each _, _) diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index ee69248ba..6c396fb08 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -60,6 +60,7 @@ and expression_content = (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip | E_tuple of expression list @@ -118,6 +119,13 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} + and sequence = { expr1: expression ; expr2: expression ; diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index e2f86622e..b57e65bcb 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -93,10 +93,15 @@ and expression_content ppf (ec : expression_content) = expression rhs option_inline inline expression let_result - | E_sequence {expr1;expr2} -> - fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation + | E_cond {condition; then_clause; else_clause} -> + fprintf ppf "if %a then %a else %a" + expression condition + expression then_clause + expression else_clause + | E_sequence {expr1;expr2} -> + fprintf ppf "{ %a; @. %a}" expression expr1 expression expr2 | E_skip -> fprintf ppf "skip" | E_tuple t -> diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index cc18739c2..4edfc377f 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -122,6 +122,7 @@ let e_constant ?loc name lst = make_expr ?loc @@ E_constant {cons_name=name ; ar let e_annotation ?loc anno_expr ty = make_expr ?loc @@ E_ascription {anno_expr; type_annotation = ty} +let e_cond ?loc condition then_clause else_clause = make_expr ?loc @@ E_cond {condition;then_clause;else_clause} let e_sequence ?loc expr1 expr2 = make_expr ?loc @@ E_sequence {expr1; expr2} let e_skip ?loc () = make_expr ?loc @@ E_skip @@ -153,7 +154,6 @@ let make_option_typed ?loc e t_opt = | None -> e | Some t -> e_annotation ?loc e t -let e_cond ?loc expr match_true match_false = e_matching expr ?loc (Match_bool {match_true; match_false}) let e_tuple ?loc lst : expression = e_record_ez ?loc (tuple_to_record lst) let e_pair ?loc a b : expression = e_tuple ?loc [a;b] diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index a8d7b5919..1fa10df89 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -84,6 +84,7 @@ val e_record_accessor_list : ?loc:Location.t -> expression -> string list -> exp val e_annotation : ?loc:Location.t -> expression -> type_expression -> expression +val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_sequence : ?loc:Location.t -> expression -> expression -> expression val e_skip : ?loc:Location.t -> unit -> expression @@ -109,7 +110,6 @@ val e_typed_big_map : ?loc:Location.t -> ( expression * expression ) list -> ty val e_typed_set : ?loc:Location.t -> expression list -> type_expression -> expression val e_record_ez : ?loc:Location.t -> (string * expression) list -> expression -val e_cond: ?loc:Location.t -> expression -> expression -> expression -> expression val e_tuple : ?loc:Location.t -> expression list -> expression val e_pair : ?loc:Location.t -> expression -> expression -> expression diff --git a/src/stages/2-ast_sugar/misc.ml b/src/stages/2-ast_sugar/misc.ml index 2d43bf2a9..508ae70d9 100644 --- a/src/stages/2-ast_sugar/misc.ml +++ b/src/stages/2-ast_sugar/misc.ml @@ -204,7 +204,8 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | (E_application _, _) | (E_let_in _, _) | (E_recursive _,_) | (E_record_accessor _, _) | (E_tuple_accessor _, _) - | (E_look_up _, _) | (E_matching _, _) + | (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) diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index f4650284c..cd648c754 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -60,6 +60,7 @@ and expression_content = (* Advanced *) | E_ascription of ascription (* Sugar *) + | E_cond of conditional | E_sequence of sequence | E_skip | E_tuple of expression list @@ -113,6 +114,12 @@ and matching = } and ascription = {anno_expr: expression; type_annotation: type_expression} + +and conditional = { + condition : expression ; + then_clause : expression ; + else_clause : expression ; +} and sequence = { expr1: expression ; expr2: expression ; From 3d3da33e3ea67b660cbddc0658b073af53cbf934 Mon Sep 17 00:00:00 2001 From: Sander Spies Date: Wed, 1 Apr 2020 15:35:09 +0200 Subject: [PATCH 6/8] Add background-color to options of Syntax Switch. --- .../@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js | 8 ++++---- .../src/@ligo/syntax/output/theme/Syntax/index.js | 4 ++-- .../syntax/output/theme/Syntax/styles.module.css | 1 + .../@ligo/syntax/output/theme/SyntaxTitle/index.js | 12 ++++++------ .../@ligo/syntax/src/theme/Syntax/styles.module.css | 1 + 5 files changed, 14 insertions(+), 12 deletions(-) diff --git a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js index eea544e69..5d503743d 100644 --- a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js +++ b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/SyntaxSwitch.js @@ -2,15 +2,15 @@ import React from 'react'; import styles from './styles.module.css'; function SyntaxSwitch(props) { - return React.createElement("select", { + return /*#__PURE__*/React.createElement("select", { className: styles.syntaxSwitch, defaultValue: props.syntax, onChange: e => props.onSyntaxChange(e.target.value) - }, React.createElement("option", { + }, /*#__PURE__*/React.createElement("option", { value: "pascaligo" - }, "PascaLIGO"), React.createElement("option", { + }, "PascaLIGO"), /*#__PURE__*/React.createElement("option", { value: "cameligo" - }, "CameLIGO"), React.createElement("option", { + }, "CameLIGO"), /*#__PURE__*/React.createElement("option", { value: "reasonligo" }, "ReasonLIGO")); } diff --git a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/index.js b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/index.js index bfec0dfc0..91a888198 100644 --- a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/index.js +++ b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/index.js @@ -2,11 +2,11 @@ import React from 'react'; import SyntaxContext from './SyntaxContext'; function Syntax(props) { - return React.createElement(SyntaxContext.Consumer, null, syntax => { + return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => { if (syntax === props.syntax) { return props.children; } else { - return React.createElement(React.Fragment, null); + return /*#__PURE__*/React.createElement(React.Fragment, null); } }); } diff --git a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/styles.module.css b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/styles.module.css index 8875a80fb..21be7d28e 100644 --- a/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/styles.module.css +++ b/gitlab-pages/website/src/@ligo/syntax/output/theme/Syntax/styles.module.css @@ -32,6 +32,7 @@ .syntaxSwitch option { color: var(--color-primary-text); font-weight:normal; + background-color: var(--ifm-navbar-background-color); } \ No newline at end of file diff --git a/gitlab-pages/website/src/@ligo/syntax/output/theme/SyntaxTitle/index.js b/gitlab-pages/website/src/@ligo/syntax/output/theme/SyntaxTitle/index.js index b607008aa..e092c38b6 100644 --- a/gitlab-pages/website/src/@ligo/syntax/output/theme/SyntaxTitle/index.js +++ b/gitlab-pages/website/src/@ligo/syntax/output/theme/SyntaxTitle/index.js @@ -72,9 +72,9 @@ function SyntaxTitle(props) { useEffect(() => { setMounted(true); }, []); - return React.createElement(SyntaxContext.Consumer, null, syntax => { + return /*#__PURE__*/React.createElement(SyntaxContext.Consumer, null, syntax => { if (syntax === props.syntax) { - return React.createElement(Highlight, _extends({}, defaultProps, { + return /*#__PURE__*/React.createElement(Highlight, _extends({}, defaultProps, { key: mounted, language: props.syntax, code: props.children, @@ -85,7 +85,7 @@ function SyntaxTitle(props) { tokens, getLineProps, getTokenProps - }) => React.createElement("pre", { + }) => /*#__PURE__*/React.createElement("pre", { className: className, style: { backgroundColor: 'var(--ifm-background-color)', @@ -95,15 +95,15 @@ function SyntaxTitle(props) { whiteSpace: 'break-spaces', marginTop: '3rem' } - }, tokens.map((line, i) => React.createElement("div", getLineProps({ + }, tokens.map((line, i) => /*#__PURE__*/React.createElement("div", getLineProps({ line, key: i - }), line.map((token, key) => React.createElement("span", getTokenProps({ + }), line.map((token, key) => /*#__PURE__*/React.createElement("span", getTokenProps({ token, key }))))))); } else { - return React.createElement("div", null); + return /*#__PURE__*/React.createElement("div", null); } }); } diff --git a/gitlab-pages/website/src/@ligo/syntax/src/theme/Syntax/styles.module.css b/gitlab-pages/website/src/@ligo/syntax/src/theme/Syntax/styles.module.css index 8875a80fb..21be7d28e 100644 --- a/gitlab-pages/website/src/@ligo/syntax/src/theme/Syntax/styles.module.css +++ b/gitlab-pages/website/src/@ligo/syntax/src/theme/Syntax/styles.module.css @@ -32,6 +32,7 @@ .syntaxSwitch option { color: var(--color-primary-text); font-weight:normal; + background-color: var(--ifm-navbar-background-color); } \ No newline at end of file From 57fc351907cf909524fa40cf9560e8479b370724 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Wed, 1 Apr 2020 14:22:05 -0500 Subject: [PATCH 7/8] Remove dexter.ligo --- dexter.ligo | 585 ---------------------------------------------------- 1 file changed, 585 deletions(-) delete mode 100644 dexter.ligo diff --git a/dexter.ligo b/dexter.ligo deleted file mode 100644 index 0af2bb11d..000000000 --- a/dexter.ligo +++ /dev/null @@ -1,585 +0,0 @@ -// Dexter -// a decentralized Tezos exchange for XTZ and FA1.2 -// copyright: camlCase 2019-2020 -// version: 0.1.5.0 - -// ============================================================================= -// Entrypoints -// ============================================================================= - -type entrypoint is -| Approve of (address * nat * nat) -| AddLiquidity of (address * nat * nat * timestamp) -| RemoveLiquidity of (address * address * nat * tez * nat * timestamp) -| XtzToToken of (address * nat * timestamp) -| TokenToXtz of (address * address * nat * tez * timestamp) -| BetForBakingRights of (key_hash * address * nat) -| EndAuctionRound -| UpdateTokenBalance of (nat) - -// the transfer entrypoint of the FA1.2 contract -type token_contract_transfer is (address * address * nat); - -// ============================================================================= -// Storage -// ============================================================================= - -type baker_address is key_hash; - -type account is record - balance : nat; - allowances: map(address, nat); -end - -// this is just to force big_maps as the first item of a pair on the top -// so we can still use the old big map route without big map id for -// convenience -type s is record - current_baker: option(baker_address); - current_baker_candidate: option(baker_address * address * tez * nat); - last_auction: timestamp; - lqt_total: nat; - token_address: address; - token_balance: nat; - rewards: (tez * nat); -end - -type storage is record - s: s; - accounts: big_map(address, account); -end - -// ============================================================================= -// Constants -// ============================================================================= - -const empty_allowances : map(address,nat) = map end; - -const empty_ops : list(operation) = list end; - -const no_baker_candidate: option(baker_address * address * tez * nat) = None; - -const no_baker: option(key_hash) = None; - -// 21 days -// 86400 seconds * 21 -const dexter_cycle: int = 1814400; - -// ============================================================================= -// Helper Functions -// ============================================================================= - -function mutez_to_natural(const a: tez): nat is - block {skip} with a / 1mutez - -function natural_to_mutez(const a: nat): tez is - block {skip} with a * 1mutez - -// this will fail if provided a negative number -function int_to_nat(const error: string ; const a: int): nat is - block { - var result : nat := 0n; - if (a >= 0) then block { - result := abs(a); - } else block { - failwith(error) - }; - } with result; - -// get an account from the big_map, if one does not exist for a particular -// address then create one. -function get_account(const a: address ; const m: big_map(address, account)): account is - block { skip } with ( - case (m[a]) of - | None -> record balance = 0n; allowances = empty_allowances; end - | Some(account) -> account - end - ); - -function update_allowance(const owner : address; - const spender : address; - const updated_allowance: nat; - var storage : storage): - storage is - block { - if (spender =/= owner) then block { - var account: account := get_account(owner, storage.accounts); - account.allowances[spender] := updated_allowance; - storage.accounts[owner] := record balance = account.balance; allowances = account.allowances; end; - } else { - skip; - } - } with storage; - -// if sender is owner, return amount, otherwise check if sender has permission -// if true then return amount, otherwise fail -function get_sender_allowance(const owner: address ; const storage: storage): nat is - block { - var result: nat := 0n; - case storage.accounts[owner] of - | None -> failwith("2") - | Some(account) -> block { - if sender =/= owner then block { - case account.allowances[sender] of - | None -> failwith("3") - | Some(allowance) -> result := allowance - end; - } else block { - result := account.balance - } - } - end; - } with result; - -function get_current_candidate_bet (const storage: storage): (tez * nat) is - block { - var current_candidate_bet: (tez * nat) := (0mutez, 0n); - case (storage.s.current_baker_candidate) of - | None -> skip - | Some(current_baker_candidate) -> current_candidate_bet := (current_baker_candidate.2, current_baker_candidate.3) - end - } with current_candidate_bet; - -// there might be some zero division edge cases -function get_xtz_pool (const current_candidate_bet_xtz: tez ; const storage: storage): (tez) is - block { - const time_since_last_auction: int = now - storage.s.last_auction; - const days_since_last_auction: int = time_since_last_auction / 86400; - var xtz_pool : tez := 0mutez; - - if (days_since_last_auction < dexter_cycle) then block { - const released_rewards : tez = (storage.s.rewards.0 / abs((days_since_last_auction * 1000 / dexter_cycle))) / 1000n; - const unreleased_rewards: tez = storage.s.rewards.0 - released_rewards; - - xtz_pool := balance - current_candidate_bet_xtz - unreleased_rewards - amount; - } else block { - // the slow reward wait has passed, all the rewards are released - - xtz_pool := balance - current_candidate_bet_xtz - amount; - }; - } with xtz_pool; - -// there might be some zero division edge cases -function get_token_pool (const current_candidate_bet_token: nat ; const storage: storage): (nat) is - block { - const time_since_last_auction: int = now - storage.s.last_auction; - const days_since_last_auction: int = time_since_last_auction / 86400; - var token_pool : nat := 0n; - - if (days_since_last_auction < dexter_cycle) then block { - const reward_days : int = days_since_last_auction; - const released_rewards : nat = (storage.s.rewards.1 / abs((reward_days * 1000 / dexter_cycle))) / 1000n; - const unreleased_rewards: nat = abs(storage.s.rewards.1 - released_rewards); - - token_pool := abs(storage.s.token_balance - current_candidate_bet_token - unreleased_rewards); - } else block { - // the slow reward wait has passed, all the rewards are released - token_pool := abs(storage.s.token_balance - current_candidate_bet_token) - }; - } with token_pool; - -// ============================================================================= -// Entrypoint Functions -// ============================================================================= - -function approve(const spender : address; - const allowance: nat; - const current_allowance: nat; - var storage : storage): - (list(operation) * storage) is - block { - if (spender =/= sender) then block { - // get the sender's account - // if the account does not exist, fail, we do not want to create accounts here - // creating accounts should be done in add_liquidity - const account: account = get_account(sender, storage.accounts); - - var sender_allowances: map(address, nat) := account.allowances; - sender_allowances[spender] := allowance; - storage.accounts[sender] := record balance = account.balance; allowances = sender_allowances; end; - } else block { - failwith("1"); - } - } with (empty_ops, storage); - -// it is assumed that the exchange contract has permission from the FA1.2 token -// to manage the assets of the user. It is the responsibility of the dApp -// developer to handle permissions. -function add_liquidity(const owner : address; - const min_lqt_created : nat; - const max_tokens_deposited: nat; - const deadline : timestamp; - var storage : storage): - (list(operation) * storage) is - block { - // add_liquidity performs a transfer to the token contract, we need to - // return the operations - var op_list: list(operation) := nil; - - if (now < deadline) then skip else block { - failwith("4"); - }; - - if (max_tokens_deposited > 0n) then skip else block { - failwith("5"); - }; - - if (amount > 0mutez) then skip else block { - failwith("6"); - }; - - if (storage.s.lqt_total > 0n) then block { - // lqt_total greater than zero - // use the existing exchange rate - - if (min_lqt_created > 0n) then skip else block { - failwith("7"); - }; - - const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); - const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); - const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); - const nat_amount : nat = mutez_to_natural(amount); - const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; - const lqt_minted : nat = nat_amount * storage.s.lqt_total / xtz_pool; - - if (max_tokens_deposited >= tokens_deposited) then skip else block { - failwith("8"); - }; - - if (lqt_minted >= min_lqt_created) then skip else block { - failwith("9"); - }; - - const account: account = get_account(owner, storage.accounts); - const new_balance: nat = account.balance + lqt_minted; - storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; - storage.s.lqt_total := storage.s.lqt_total + lqt_minted; - storage.s.token_balance := storage.s.token_balance + tokens_deposited; - - // send FA1.2 from owner to exchange - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); - op_list := list op1; end; - - } else block { - // initial add liquidity - if (amount >= 1tz) then skip else block { - failwith("10"); - }; - - const tokens_deposited : nat = max_tokens_deposited; - const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); - const initial_liquidity : nat = mutez_to_natural(balance - current_candidate_bet.0); - - storage.s.lqt_total := initial_liquidity; - storage.accounts[owner] := record balance = initial_liquidity; allowances = empty_allowances; end; - storage.s.token_balance := tokens_deposited; - - // send FA1.2 tokens from owner to exchange - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const op1: operation = transaction((owner, self_address, tokens_deposited), 0mutez, token_contract); - op_list := list op1; end; - } - } with (op_list, storage); - -function remove_liquidity(const owner : address; - const to_ : address; - const lqt_burned : nat; - const min_xtz_withdrawn : tez; - const min_tokens_withdrawn : nat; - const deadline : timestamp; - var storage : storage): - (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - if (now < deadline) then skip else block { - failwith("11"); - }; - - if (min_xtz_withdrawn > 0mutez) then skip else block { - failwith("12"); - }; - - if (min_tokens_withdrawn > 0n) then skip else block { - failwith("13"); - }; - - if (lqt_burned > 0n) then skip else block { - failwith("14"); - }; - - // returns total if sender is owner, otherwise looks it up - const lqt: nat = get_sender_allowance(owner, storage); - - if (lqt >= lqt_burned) then skip else block { - failwith("15"); - }; - - if (storage.s.lqt_total > 0n) then skip else block { - failwith("16"); - }; - - const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); - const xtz_withdrawn : tez = natural_to_mutez(lqt_burned * mutez_to_natural(balance - current_candidate_bet.0) / storage.s.lqt_total); - - if (xtz_withdrawn >= min_xtz_withdrawn) then skip else block { - failwith("17"); - }; - - const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); - const tokens_withdrawn: nat = lqt_burned * token_pool / storage.s.lqt_total; - - if (tokens_withdrawn >= min_tokens_withdrawn) then skip else block { - failwith("18"); - }; - - const account: account = get_account(owner, storage.accounts); - - if (account.balance >= lqt_burned) then skip else block { - failwith("19"); - }; - - const new_balance: nat = int_to_nat("33", account.balance - lqt_burned); - storage.accounts[owner] := record balance = new_balance; allowances = account.allowances; end; - - storage.s.lqt_total := int_to_nat("34", storage.s.lqt_total - lqt_burned); - storage.s.token_balance := int_to_nat("35", storage.s.token_balance - tokens_withdrawn); - - // update allowance - // lqt - lqt_burned is safe, we have already checed that lqt >= lqt_burned - storage := update_allowance(owner, sender, int_to_nat("36", lqt - lqt_burned), storage); - - // send xtz_withdrawn to to_ address - const to_contract: contract(unit) = get_contract(to_); - const op1: operation = transaction(unit, xtz_withdrawn, to_contract); - - // send tokens_withdrawn to to address - // if tokens_withdrawn if greater than storage.s.token_balance, this will fail - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const op2: operation = transaction((self_address, to_, tokens_withdrawn), 0mutez, token_contract); - op_list := list op1; op2; end - } with (op_list, storage); - -function xtz_to_token(const to_ : address; - const min_tokens_bought: nat; - const deadline : timestamp; - var storage : storage): - (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - if (now < deadline) then skip else block { - failwith("20"); - }; - - const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); - const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); - const nat_amount : nat = mutez_to_natural(amount); - const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); - const tokens_bought : nat = (nat_amount * 997n * token_pool) / (xtz_pool * 1000n + (nat_amount * 997n)); - - if (tokens_bought >= min_tokens_bought) then skip else block { - failwith("21"); - }; - - storage.s.token_balance := int_to_nat("32", storage.s.token_balance - tokens_bought); - - // send tokens_withdrawn to to address - // if tokens_bought is greater than storage.s.token_balance, this will fail - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const op: operation = transaction((self_address, to_, tokens_bought), 0mutez, token_contract); - - // append internal operations - op_list := list op; end; - } with (op_list, storage); - -function token_to_xtz(const owner : address; // the address of the owner of FA1.2 - const to_ : address; - const tokens_sold : nat; - const min_xtz_bought: tez; - const deadline : timestamp; - var storage : storage): - (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - if (now < deadline) then skip else block { - failwith("22"); - }; - - const current_candidate_bet: (tez * nat) = get_current_candidate_bet(storage); - const xtz_pool : tez = get_xtz_pool(current_candidate_bet.0, storage); - const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); - const xtz_bought : tez = natural_to_mutez((tokens_sold * 997n * mutez_to_natural(xtz_pool)) / (token_pool * 1000n + (tokens_sold * 997n))); - - if (xtz_bought >= min_xtz_bought) then skip else block { - failwith("23"); - }; - - storage.s.token_balance := storage.s.token_balance + tokens_sold; - - // send xtz_bought to to_ address - const to_contract: contract(unit) = get_contract(to_); - const op1: operation = transaction(unit, xtz_bought, to_contract); - - // send tokens_sold to the exchange address - // this assumes that the exchange has an allowance for the token and owner in FA1.2 - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const op2: operation = transaction((owner, self_address, tokens_sold), 0mutez, token_contract); - - // append internal operations - op_list := list op1; op2; end; - } with (op_list, storage); - -function assert_valid_baker (const current_baker: option(key_hash); - const candidate: key_hash): (operation * operation) is - block { - // test the candidate baker, if it is valid this will not fail - const test_set_delegate_operation: operation = set_delegate(Some(candidate)); - - // reset to the current baker - const reset_set_delegate_operation: operation = set_delegate(current_baker); - } with (test_set_delegate_operation, reset_set_delegate_operation); - -function bet_for_baking_rights (const candidate : key_hash; - const token_source : address; - const max_tokens_bet : nat; - var storage : storage): - (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - - // this is a trick to assert that the provided baker address is valid - case (storage.s.current_baker_candidate) of - | None -> block { - const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); - op_list := op_pair.0 # op_list; - op_list := op_pair.1 # op_list; - } - | Some(current_baker_candidate) -> block { - if (current_baker_candidate.0 = candidate) then skip else block { - const op_pair: (operation * operation) = assert_valid_baker(storage.s.current_baker, candidate); - op_list := op_pair.0 # op_list; - op_list := op_pair.1 # op_list; - }; - } - end; - - // now we are sure it is a valid baker - - // set a minimum bet - if (max_tokens_bet > 0n) then skip else block { - failwith("24"); - }; - - if (amount > 0mutez) then skip else block { - failwith("25"); - }; - - const current_candidate_bet : (tez * nat) = get_current_candidate_bet(storage); - - if (amount > current_candidate_bet.0) then skip else { failwith("26") }; - - const xtz_pool : nat = mutez_to_natural(get_xtz_pool(current_candidate_bet.0, storage)); - const token_pool : nat = get_token_pool(current_candidate_bet.1, storage); - const nat_amount : nat = mutez_to_natural(amount); - const tokens_deposited : nat = nat_amount * token_pool / xtz_pool; - - if (tokens_deposited > current_candidate_bet.1) then skip else { failwith("27") }; - if (tokens_deposited > max_tokens_bet) then skip else { failwith("28") }; - - case (storage.s.current_baker_candidate) of - | None -> block { - // add the tokens_deposited to the token_balance - storage.s.token_balance := storage.s.token_balance + tokens_deposited; - } - | Some(current_baker_candidate) -> block { - // return rejected candidates tez and tokens to previous candidate - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const return_token_op: operation = transaction((self_address, current_baker_candidate.1, current_baker_candidate.3), 0mutez, token_contract); - op_list := return_token_op # op_list; - - const to_contract: contract(unit) = get_contract(current_baker_candidate.1); - const return_xtz_op: operation = transaction(unit, current_baker_candidate.2, to_contract); - op_list := return_xtz_op # op_list; - - // remove the tokens from the current_baker_candidate - // add the tokens_deposited to the token_balance - storage.s.token_balance := abs(storage.s.token_balance - current_baker_candidate.3) + tokens_deposited; - } - end; - - storage.s.current_baker_candidate := Some((candidate,token_source,amount,tokens_deposited)); - - // send FA1.2 from owner to exchange, dexter needs permission to transfer these tokens - const token_contract: contract(token_contract_transfer) = get_entrypoint("%transfer", storage.s.token_address); - const xtz_to_dexter_op: operation = transaction((token_source, self_address, tokens_deposited), 0mutez, token_contract); - op_list := xtz_to_dexter_op # op_list; - - } with (op_list, storage); - -function end_auction_round(var storage : storage) : (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - // 604800 seconds is one week - if (now > storage.s.last_auction + 604800) then skip else {failwith("29")}; - - case (storage.s.current_baker_candidate) of - | None -> block { - const set_delegate_op: operation = set_delegate(no_baker); - op_list := set_delegate_op # op_list; - } - | Some(current_baker_candidate) -> block { - case (storage.s.current_baker) of - | None -> block { - storage.s.current_baker := Some(current_baker_candidate.0); - storage.s.current_baker_candidate := no_baker_candidate; - storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; - storage.s.last_auction := now; - const set_delegate_op: operation = set_delegate(storage.s.current_baker); - op_list := set_delegate_op # op_list; - } - | Some(current_baker) -> block { - if (current_baker = current_baker_candidate.0) then block { - storage.s.current_baker_candidate := no_baker_candidate; - storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; - storage.s.last_auction := now; - } else { - storage.s.current_baker := Some(current_baker_candidate.0); - storage.s.current_baker_candidate := no_baker_candidate; - storage.s.token_balance := storage.s.token_balance + current_baker_candidate.3; - storage.s.last_auction := now; - const set_delegate_op: operation = set_delegate(storage.s.current_baker); - op_list := set_delegate_op # op_list; - } - } - end; - } - end; - - } with (op_list, storage); - -function update_token_balance(const token_balance: nat ; var storage : storage) : (list(operation) * storage) is - block { - var op_list: list(operation) := nil; - if (sender =/= storage.s.token_address) then { - failwith("31"); - } else { - storage.s.token_balance := token_balance; - } - } with (op_list, storage); - -// ============================================================================= -// Main -// ============================================================================= - -function main (const entrypoint : entrypoint ; const storage : storage) : (list(operation) * storage) is - (case entrypoint of - | Approve(xs) -> approve(xs.0,xs.1,xs.2,storage) - | AddLiquidity(xs) -> add_liquidity(xs.0,xs.1,xs.2,xs.3,storage) - | RemoveLiquidity(xs) -> remove_liquidity(xs.0,xs.1,xs.2,xs.3,xs.4,xs.5,storage) - | XtzToToken(xs) -> xtz_to_token(xs.0,xs.1,xs.2,storage) - | TokenToXtz(xs) -> token_to_xtz(xs.0,xs.1,xs.2,xs.3,xs.4,storage) - | BetForBakingRights(xs) -> bet_for_baking_rights(xs.0,xs.1,xs.2,storage) - | EndAuctionRound -> end_auction_round(storage) - | UpdateTokenBalance(xs) -> update_token_balance(xs, storage) - end); From 6fed8998bb49a839ac3e1bc563fed1cc545344b3 Mon Sep 17 00:00:00 2001 From: Tom Jack Date: Mon, 23 Mar 2020 15:14:55 -0500 Subject: [PATCH 8/8] Somewhat better PP for ast_core and mini_c --- src/bin/expect_tests/contract_tests.ml | 8 +- src/bin/expect_tests/typer_error_tests.ml | 4 +- .../11-self_mini_c/michelson_restrictions.ml | 6 +- src/passes/11-self_mini_c/subst.ml | 62 +++++++-------- src/stages/3-ast_core/PP.ml | 38 +++++----- src/stages/5-mini_c/PP.ml | 76 ++++++++++--------- src/stages/common/PP.ml | 18 ++--- 7 files changed, 109 insertions(+), 103 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 3419ad93b..5cff60cca 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -26,7 +26,7 @@ let%expect_test _ = run_ligo_bad [ "compile-storage" ; contract "coase.ligo" ; "main" ; "Buy_single (record card_to_buy = 1n end)" ] ; [%expect {| - ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]"} + ligo: different kinds: {"a":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]","b":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]"} If you're not sure how to fix this error, you can @@ -39,7 +39,7 @@ let%expect_test _ = run_ligo_bad [ "compile-parameter" ; contract "coase.ligo" ; "main" ; "record cards = (map end : cards) ; card_patterns = (map end : card_patterns) ; next_id = 3n ; end" ] ; [%expect {| - ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] , Sell_single -> record[card_to_sell -> nat] , Transfer_single -> record[card_to_transfer -> nat , destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) , cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) , next_id -> nat]"} + ligo: different kinds: {"a":"sum[Buy_single -> record[card_to_buy -> nat] ,\n Sell_single -> record[card_to_sell -> nat] ,\n Transfer_single -> record[card_to_transfer -> nat ,\n destination -> address]]","b":"record[card_patterns -> (TO_Map (nat,record[coefficient -> mutez , quantity -> nat])) ,\n cards -> (TO_Map (nat,record[card_owner -> address , card_pattern -> nat])) ,\n next_id -> nat]"} If you're not sure how to fix this error, you can @@ -1117,7 +1117,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_toplevel.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return let rhs#702 = #P in let p = rhs#702.0 in let s = rhs#702.1 in ( LIST_EMPTY() : (TO_list(operation)) , store ) , NONE() : (TO_option(key_hash)) , 300000000mutez , \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} +ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, character 8. No free variable allowed in this lambda: variable 'store' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * string ))) : None return\n let rhs#702 = #P in\n let p = rhs#702.0 in\n let s = rhs#702.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , store ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n \"un\")","location":"in file \"create_contract_toplevel.mligo\", line 4, character 35 to line 8, character 8"} If you're not sure how to fix this error, you can @@ -1130,7 +1130,7 @@ ligo: in file "create_contract_toplevel.mligo", line 4, character 35 to line 8, run_ligo_bad [ "compile-contract" ; bad_contract "create_contract_var.mligo" ; "main" ] ; [%expect {| -ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return let rhs#705 = #P in let p = rhs#705.0 in let s = rhs#705.1 in ( LIST_EMPTY() : (TO_list(operation)) , a ) , NONE() : (TO_option(key_hash)) , 300000000mutez , 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} +ligo: in file "create_contract_var.mligo", line 6, character 35 to line 10, character 5. No free variable allowed in this lambda: variable 'a' {"expression":"CREATE_CONTRACT(lambda (#P:Some(( nat * int ))) : None return\n let rhs#705 = #P in\n let p = rhs#705.0 in\n let s = rhs#705.1 in\n ( LIST_EMPTY() : (TO_list(operation)) , a ) ,\n NONE() : (TO_option(key_hash)) ,\n 300000000mutez ,\n 1)","location":"in file \"create_contract_var.mligo\", line 6, character 35 to line 10, character 5"} If you're not sure how to fix this error, you can diff --git a/src/bin/expect_tests/typer_error_tests.ml b/src/bin/expect_tests/typer_error_tests.ml index facf1e75c..a52cd6e68 100644 --- a/src/bin/expect_tests/typer_error_tests.ml +++ b/src/bin/expect_tests/typer_error_tests.ml @@ -158,7 +158,9 @@ let%expect_test _ = run_ligo_bad [ "compile-contract" ; "../../test/contracts/negative/id.mligo" ; "main" ] ; [%expect {| - ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , owner -> address , profile -> bytes] + ligo: in file "id.mligo", line 45, characters 4-51. Expected a different type: Expected the type option but got the type record[controller -> address , + owner -> address , + profile -> bytes] If you're not sure how to fix this error, you can do one of the following: diff --git a/src/passes/11-self_mini_c/michelson_restrictions.ml b/src/passes/11-self_mini_c/michelson_restrictions.ml index 80fe2cf73..88bab055f 100644 --- a/src/passes/11-self_mini_c/michelson_restrictions.ml +++ b/src/passes/11-self_mini_c/michelson_restrictions.ml @@ -5,9 +5,9 @@ module Errors = struct let bad_self_address cst () = let title = thunk @@ - Format.asprintf "Wrong %alocation" Mini_c.PP.expression' cst in + Format.asprintf "Wrong %a location" Stage_common.PP.constant cst in let message = thunk @@ - Format.asprintf "%ais only allowed at top-level" Mini_c.PP.expression' cst in + Format.asprintf "%a is only allowed at top-level" Stage_common.PP.constant cst in error title message () end @@ -19,7 +19,7 @@ let self_in_lambdas : expression -> expression result = | E_closure {binder=_ ; body} -> let%bind _self_in_lambdas = Helpers.map_expression (fun e -> match e.content with - | E_constant {cons_name=C_SELF_ADDRESS; _} as c -> fail (bad_self_address c) + | E_constant {cons_name=C_SELF_ADDRESS; _} -> fail (bad_self_address C_SELF_ADDRESS) | _ -> ok e) body in ok e diff --git a/src/passes/11-self_mini_c/subst.ml b/src/passes/11-self_mini_c/subst.ml index 1637a7bbe..def581f96 100644 --- a/src/passes/11-self_mini_c/subst.ml +++ b/src/passes/11-self_mini_c/subst.ml @@ -225,7 +225,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x))[x := L(unit)] = + (x)[x := L(unit)] = L(unit) |}] ; (* other var *) @@ -235,8 +235,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(y))[x := L(unit)] = - V(y) + (y)[x := L(unit)] = + y |}] ; (* closure shadowed *) @@ -246,8 +246,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (C(fun x -> (V(x))))[x := L(unit)] = - C(fun x -> (V(x))) + (fun x -> (x))[x := L(unit)] = + fun x -> (x) |}] ; (* closure not shadowed *) @@ -257,8 +257,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (C(fun y -> (V(x))))[x := L(unit)] = - C(fun y -> (L(unit))) + (fun y -> (x))[x := L(unit)] = + fun y -> (L(unit)) |}] ; (* closure capture-avoidance *) @@ -268,8 +268,8 @@ let%expect_test _ = ~x:x ~expr:(wrap (E_variable y)) ; [%expect{| - (C(fun y -> ((V(x))@(V(y)))))[x := V(y)] = - C(fun y#1 -> ((V(y))@(V(y#1)))) + (fun y -> ((x)@(y)))[x := y] = + fun y#1 -> ((y)@(y#1)) |}] ; (* let-in shadowed (not in rhs) *) @@ -279,8 +279,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (let x = V(x) in ( V(x) ))[x := L(unit)] = - let x = L(unit) in ( V(x) ) + (let x = x in x)[x := L(unit)] = + let x = L(unit) in x |}] ; (* let-in not shadowed *) @@ -290,8 +290,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (let y = V(x) in ( V(x) ))[x := L(unit)] = - let y = L(unit) in ( L(unit) ) + (let y = x in x)[x := L(unit)] = + let y = L(unit) in L(unit) |}] ; (* let-in capture avoidance *) @@ -302,8 +302,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (let y = V(x) in ( (V(x))@(V(y)) ))[x := V(y)] = - let y#1 = V(y) in ( (V(y))@(V(y#1)) ) + (let y = x in (x)@(y))[x := y] = + let y#1 = y in (y)@(y#1) |}] ; (* iter shadowed *) @@ -313,8 +313,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (for_ITER x of V(x) do ( V(x) ))[x := L(unit)] = - for_ITER x of L(unit) do ( V(x) ) + (for_ITER x of x do ( x ))[x := L(unit)] = + for_ITER x of L(unit) do ( x ) |}] ; (* iter not shadowed *) @@ -324,7 +324,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (for_ITER y of V(x) do ( V(x) ))[x := L(unit)] = + (for_ITER y of x do ( x ))[x := L(unit)] = for_ITER y of L(unit) do ( L(unit) ) |}] ; @@ -335,8 +335,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (for_ITER y of (V(x))@(V(y)) do ( (V(x))@(V(y)) ))[x := V(y)] = - for_ITER y#1 of (V(y))@(V(y)) do ( (V(y))@(V(y#1)) ) + (for_ITER y of (x)@(y) do ( (x)@(y) ))[x := y] = + for_ITER y#1 of (y)@(y) do ( (y)@(y#1) ) |}] ; (* if_cons shadowed 1 *) @@ -349,8 +349,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (x :: y) -> V(x))[x := L(unit)] = - L(unit) ?? L(unit) : (x :: y) -> V(x) + (x ?? x : (x :: y) -> x)[x := L(unit)] = + L(unit) ?? L(unit) : (x :: y) -> x |}] ; (* if_cons shadowed 2 *) @@ -363,8 +363,8 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (y :: x) -> V(x))[x := L(unit)] = - L(unit) ?? L(unit) : (y :: x) -> V(x) + (x ?? x : (y :: x) -> x)[x := L(unit)] = + L(unit) ?? L(unit) : (y :: x) -> x |}] ; (* if_cons not shadowed *) @@ -377,7 +377,7 @@ let%expect_test _ = ~x:x ~expr:unit ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> V(x))[x := L(unit)] = + (x ?? x : (y :: z) -> x)[x := L(unit)] = L(unit) ?? L(unit) : (y :: z) -> L(unit) |}] ; @@ -391,8 +391,8 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(y)] = - V(y) ?? V(y) : (y#1 :: z) -> (V(y))@((V(y#1))@(V(z))) + (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := y] = + y ?? y : (y#1 :: z) -> (y)@((y#1)@(z)) |}] ; (* if_cons capture avoidance 2 *) @@ -405,8 +405,8 @@ let%expect_test _ = ~x:x ~expr:(var z) ; [%expect{| - (V(x) ?? V(x) : (y :: z) -> (V(x))@((V(y))@(V(z))))[x := V(z)] = - V(z) ?? V(z) : (y :: z#1) -> (V(z))@((V(y))@(V(z#1))) + (x ?? x : (y :: z) -> (x)@((y)@(z)))[x := z] = + z ?? z : (y :: z#1) -> (z)@((y)@(z#1)) |}] ; (* old bug *) @@ -417,6 +417,6 @@ let%expect_test _ = ~x:x ~expr:(var y) ; [%expect{| - (C(fun y -> (C(fun y#1 -> ((V(x))@((V(y))@(V(y#1))))))))[x := V(y)] = - C(fun y#2 -> (C(fun y#1 -> ((V(y))@((V(y#2))@(V(y#1))))))) + (fun y -> (fun y#1 -> ((x)@((y)@(y#1)))))[x := y] = + fun y#2 -> (fun y#1 -> ((y)@((y#2)@(y#1)))) |}] ; diff --git a/src/stages/3-ast_core/PP.ml b/src/stages/3-ast_core/PP.ml index 2909d4dc8..ac760dbba 100644 --- a/src/stages/3-ast_core/PP.ml +++ b/src/stages/3-ast_core/PP.ml @@ -19,20 +19,20 @@ and expression_content ppf (ec : expression_content) = | E_variable n -> fprintf ppf "%a" expression_variable n | E_application {lamb;args} -> - fprintf ppf "(%a)@(%a)" expression lamb expression args + fprintf ppf "@[(%a)@@(%a)@]" expression lamb expression args | E_constructor c -> - fprintf ppf "%a(%a)" constructor c.constructor expression c.element + fprintf ppf "@[%a(%a)@]" constructor c.constructor expression c.element | E_constant c -> - fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) + fprintf ppf "@[%a@[(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> fprintf ppf "%a" (tuple_or_record_sep_expr expression) m | E_record_accessor ra -> - fprintf ppf "%a.%a" expression ra.record label ra.path + fprintf ppf "@[%a.%a@]" expression ra.record label ra.path | E_record_update {record; path; update} -> - fprintf ppf "{ %a with { %a = %a } }" expression record label path expression update + fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression record label path expression update | E_lambda {binder; input_type; output_type; result} -> - fprintf ppf "lambda (%a:%a) : %a return %a" + fprintf ppf "@[lambda (%a:%a) : %a@ return@ %a@]" expression_variable binder (PP_helpers.option type_expression) input_type @@ -44,10 +44,10 @@ and expression_content ppf (ec : expression_content) = type_expression fun_type expression_content (E_lambda lambda) | E_matching {matchee; cases; _} -> - fprintf ppf "match %a with %a" expression matchee (matching expression) + fprintf ppf "@[match %a with@ %a@]" expression matchee (matching expression) cases | E_let_in { let_binder ;rhs ; let_result; inline } -> - fprintf ppf "let %a = %a%a in %a" option_type_name let_binder expression rhs option_inline inline expression let_result + fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" option_type_name let_binder expression rhs option_inline inline expression let_result | E_ascription {anno_expr; type_annotation} -> fprintf ppf "%a : %a" expression anno_expr type_expression type_annotation @@ -61,27 +61,27 @@ and option_type_name ppf fprintf ppf "%a : %a" expression_variable n type_expression ty and assoc_expression ppf : expr * expr -> unit = - fun (a, b) -> fprintf ppf "%a -> %a" expression a expression b + fun (a, b) -> fprintf ppf "@[<2>%a ->@;<1 2>%a@]" expression a expression b and single_record_patch ppf ((p, expr) : label * expr) = fprintf ppf "%a <- %a" label p expression expr and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor' * expression_variable) * a -> unit = fun f ppf ((c,n),a) -> - fprintf ppf "| %a %a -> %a" constructor c expression_variable n f a + fprintf ppf "| %a %a ->@;<1 2>%a@ " constructor c expression_variable n f a and matching : type a . (formatter -> a -> unit) -> formatter -> (a,unit) matching_content -> unit = fun f ppf m -> match m with | Match_tuple ((lst, b), _) -> - fprintf ppf "let (%a) = %a" (list_sep_d expression_variable) lst f b + fprintf ppf "@[| (%a) ->@;<1 2>%a@]" (list_sep_d expression_variable) lst f b | Match_variant (lst, _) -> - fprintf ppf "%a" (list_sep (matching_variant_case f) (tag "@.")) lst + fprintf ppf "@[%a@]" (list_sep (matching_variant_case f) (tag "@ ")) lst | Match_bool {match_true ; match_false} -> - fprintf ppf "| True -> %a @.| False -> %a" f match_true f match_false + fprintf ppf "@[| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]" f match_true f match_false | Match_list {match_nil ; match_cons = (hd, tl, match_cons, _)} -> - fprintf ppf "| Nil -> %a @.| %a :: %a -> %a" f match_nil expression_variable hd expression_variable tl f match_cons + fprintf ppf "@[| Nil ->@;<1 2>%a@ | %a :: %a ->@;<1 2>%a@]" f match_nil expression_variable hd expression_variable tl f match_cons | Match_option {match_none ; match_some = (some, match_some, _)} -> - fprintf ppf "| None -> %a @.| Some %a -> %a" f match_none expression_variable some f match_some + fprintf ppf "@[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]" f match_none expression_variable some f match_some (* Shows the type expected for the matched value *) and matching_type ppf m = match m with @@ -101,22 +101,22 @@ and matching_variant_case_type ppf ((c,n),_a) = and option_mut ppf mut = if mut then - fprintf ppf "[@mut]" + fprintf ppf "[@@mut]" else fprintf ppf "" and option_inline ppf inline = if inline then - fprintf ppf "[@inline]" + fprintf ppf "[@@inline]" else fprintf ppf "" let declaration ppf (d : declaration) = match d with | Declaration_type (type_name, te) -> - fprintf ppf "type %a = %a" type_variable type_name type_expression te + fprintf ppf "@[<2>type %a =@ %a@]" type_variable type_name type_expression te | Declaration_constant (name, ty_opt, i, expr) -> - fprintf ppf "const %a = %a%a" option_type_name (name, ty_opt) expression + fprintf ppf "@[<2>const %a =@ %a%a@]" option_type_name (name, ty_opt) expression expr option_inline i diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index 808b65873..908a30e22 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -3,23 +3,21 @@ open Simple_utils.PP_helpers open Types open Format -let list_sep_d x = list_sep x (const " , ") - -let space_sep ppf () = fprintf ppf " " +let list_sep_d x = list_sep x (tag " ,@ ") let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" let rec type_variable ppf : type_value -> _ = function - | T_or(a, b) -> fprintf ppf "(%a) | (%a)" annotated a annotated b - | T_pair(a, b) -> fprintf ppf "(%a) & (%a)" annotated a annotated b + | T_or(a, b) -> fprintf ppf "@[(%a) |@ (%a)@]" annotated a annotated b + | T_pair(a, b) -> fprintf ppf "@[(%a) &@ (%a)@]" annotated a annotated b | T_base b -> type_constant ppf b - | T_function(a, b) -> fprintf ppf "(%a) -> (%a)" type_variable a type_variable b - | T_map(k, v) -> fprintf ppf "map(%a -> %a)" type_variable k type_variable v - | T_big_map(k, v) -> fprintf ppf "big_map(%a -> %a)" type_variable k type_variable v - | T_list(t) -> fprintf ppf "list(%a)" type_variable t - | T_set(t) -> fprintf ppf "set(%a)" type_variable t - | T_option(o) -> fprintf ppf "option(%a)" type_variable o - | T_contract(t) -> fprintf ppf "contract(%a)" type_variable t + | T_function(a, b) -> fprintf ppf "@[(%a) ->@ (%a)@]" type_variable a type_variable b + | T_map(k, v) -> fprintf ppf "@[<4>map(%a -> %a)@]" type_variable k type_variable v + | T_big_map(k, v) -> fprintf ppf "@[<9>big_map(%a -> %a)@]" type_variable k type_variable v + | T_list(t) -> fprintf ppf "@[<5>list(%a)@]" type_variable t + | T_set(t) -> fprintf ppf "@[<4>set(%a)@]" type_variable t + | T_option(o) -> fprintf ppf "@[<7>option(%a)@]" type_variable o + | T_contract(t) -> fprintf ppf "@[<9>contract(%a)@]" type_variable t and annotated ppf : type_value annotated -> _ = function | (Some ann, a) -> fprintf ppf "(%a %%%s)" type_variable a ann @@ -80,30 +78,38 @@ and expression ppf (e:expression) = and expression' ppf (e:expression') = match e with | E_skip -> fprintf ppf "skip" - | E_closure x -> fprintf ppf "C(%a)" function_ x - | E_variable v -> fprintf ppf "V(%a)" Var.pp v - | E_application(a, b) -> fprintf ppf "(%a)@(%a)" expression a expression b + | E_closure x -> function_ ppf x + | E_variable v -> fprintf ppf "%a" Var.pp v + | E_application(a, b) -> fprintf ppf "@[(%a)@(%a)@]" expression a expression b - | E_constant c -> fprintf ppf "%a %a" constant c.cons_name (pp_print_list ~pp_sep:space_sep expression) c.arguments - | E_literal v -> fprintf ppf "L(%a)" value v + | E_constant c -> fprintf ppf "@[%a@[(%a)@]@]" constant c.cons_name (list_sep_d expression) c.arguments + | E_literal v -> fprintf ppf "@[L(%a)@]" value v | E_make_none _ -> fprintf ppf "none" - | E_if_bool (c, a, b) -> fprintf ppf "%a ? %a : %a" expression c expression a expression b - | E_if_none (c, n, ((name, _) , s)) -> fprintf ppf "%a ?? %a : %a -> %a" expression c expression n Var.pp name expression s - | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "%a ?? %a : (%a :: %a) -> %a" expression c expression n Var.pp hd_name Var.pp tl_name expression cons + | E_if_bool (c, a, b) -> + fprintf ppf + "@[match %a with@ @[| True ->@;<1 2>%a@ | False ->@;<1 2>%a@]@]" + expression c expression a expression b + | E_if_none (c, n, ((name, _) , s)) -> + fprintf ppf + "@[match %a with@ @[| None ->@;<1 2>%a@ | Some %a ->@;<1 2>%a@]@]" + expression c expression n Var.pp name expression s + | E_if_cons (c, n, (((hd_name, _) , (tl_name, _)) , cons)) -> fprintf ppf "@[%a ?? %a : (%a :: %a) -> %a@]" expression c expression n Var.pp hd_name Var.pp tl_name expression cons | E_if_left (c, ((name_l, _) , l), ((name_r, _) , r)) -> - fprintf ppf "%a ?? %a -> %a : %a -> %a" expression c Var.pp name_l expression l Var.pp name_r expression r - | E_sequence (a , b) -> fprintf ppf "%a ;; %a" expression a expression b + fprintf ppf + "@[match %a with@ @[| Left %a ->@;<1 2>%a@ | Right %a ->@;<1 2>%a@]@]" + expression c Var.pp name_l expression l Var.pp name_r expression r + | E_sequence (a , b) -> fprintf ppf "@[%a ;; %a@]" expression a expression b | E_let_in ((name , _) , inline, expr , body) -> - fprintf ppf "let %a = %a%a in ( %a )" Var.pp name expression expr option_inline inline expression body + fprintf ppf "@[let %a =@;<1 2>%a%a in@ %a@]" Var.pp name expression expr option_inline inline expression body | E_iterator (b , ((name , _) , body) , expr) -> - fprintf ppf "for_%a %a of %a do ( %a )" constant b Var.pp name expression expr expression body + fprintf ppf "@[for_%a %a of %a do ( %a )@]" constant b Var.pp name expression expr expression body | E_fold (((name , _) , body) , collection , initial) -> - fprintf ppf "fold %a on %a with %a do ( %a )" expression collection expression initial Var.pp name expression body + fprintf ppf "@[fold %a on %a with %a do ( %a )@]" expression collection expression initial Var.pp name expression body | E_record_update (r, path,update) -> - fprintf ppf "%a with { %a = %a }" expression r (list_sep lr (const ".")) path expression update + fprintf ppf "@[{ %a@;<1 2>with@;<1 2>{ %a = %a } }@]" expression r (list_sep lr (const ".")) path expression update | E_while (e , b) -> - fprintf ppf "while %a do %a" expression e expression b + fprintf ppf "@[while %a do %a@]" expression e expression b and expression_with_type : _ -> expression -> _ = fun ppf e -> fprintf ppf "%a : %a" @@ -111,24 +117,22 @@ and expression_with_type : _ -> expression -> _ = fun ppf e -> type_variable e.type_value and function_ ppf ({binder ; body}:anon_function) = - fprintf ppf "fun %a -> (%a)" + fprintf ppf "@[fun %a ->@ (%a)@]" Var.pp binder expression body -and assignment ppf ((n, i, e):assignment) = fprintf ppf "%a = %a%a;" Var.pp n expression e option_inline i - and option_inline ppf inline = if inline then - fprintf ppf "[@inline]" + fprintf ppf "[@@inline]" else fprintf ppf "" -and declaration ppf ((n,i, e):assignment) = fprintf ppf "let %a = %a%a;" Var.pp n expression e option_inline i +and declaration ppf ((n,i, e):assignment) = fprintf ppf "@[let %a =@;<1 2>%a%a@]" Var.pp n expression e option_inline i -and tl_statement ppf (ass, _) = assignment ppf ass +and tl_statement ppf (ass, _) = declaration ppf ass and program ppf (p:program) = - fprintf ppf "Program:\n---\n%a" (pp_print_list ~pp_sep:pp_print_newline tl_statement) p + fprintf ppf "@[%a@]" (pp_print_list ~pp_sep:(tag "@ ") tl_statement) p and constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -254,9 +258,9 @@ let%expect_test _ = let wrap e = { content = e ; type_value = dummy_type } in pp @@ E_closure { binder = Var.of_name "y" ; body = wrap (E_variable (Var.of_name "y")) } ; [%expect{| - C(fun y -> (V(y))) + fun y -> (y) |}] ; pp @@ E_closure { binder = Var.of_name "z" ; body = wrap (E_variable (Var.of_name "z")) } ; [%expect{| - C(fun z -> (V(z))) + fun z -> (z) |}] diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 832609b47..5204c93f0 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -11,13 +11,13 @@ let label ppf (l:label) : unit = let cmap_sep value sep ppf m = let lst = CMap.to_kv_list m in let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in - let new_pp ppf (k, v) = fprintf ppf "%a -> %a" constructor k value v in + let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" constructor k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let record_sep value sep ppf (m : 'a label_map) = let lst = LMap.to_kv_list m in let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (k, v) = fprintf ppf "%a -> %a" label k value v in + let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" label k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let tuple_sep value sep ppf m = @@ -30,14 +30,14 @@ let tuple_sep value sep ppf m = 0..(cardinal-1) as tuples *) let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = if Helpers.is_tuple_lmap m then - fprintf ppf format_tuple (tuple_sep value (const sep_tuple)) m + fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m else - fprintf ppf format_record (record_sep value (const sep_record)) m + fprintf ppf format_record (record_sep value (tag sep_record)) m -let list_sep_d x = list_sep x (const " , ") -let cmap_sep_d x = cmap_sep x (const " , ") -let tuple_or_record_sep_expr value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " , " -let tuple_or_record_sep_type value = tuple_or_record_sep value "record[%a]" " , " "( %a )" " * " +let list_sep_d x = list_sep x (tag " ,@ ") +let cmap_sep_d x = cmap_sep x (tag " ,@ ") +let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " +let tuple_or_record_sep_type value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -206,7 +206,7 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct -> unit = fun f ppf te -> match te.type_content with - | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m + | T_sum m -> fprintf ppf "@[sum[%a]@]" (cmap_sep_d f) m | T_record m -> fprintf ppf "%a" (tuple_or_record_sep_type f) m | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_variable tv -> type_variable ppf tv