From bc7a4daa64fec6e6b7d0503145124a703a75ab03 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 21 Feb 2020 17:05:52 +0100 Subject: [PATCH 1/4] add 'mapi' equivalent for label and constructor maps --- src/stages/common/helpers.ml | 2 ++ src/stages/common/helpers.mli | 9 +++++++++ 2 files changed, 11 insertions(+) diff --git a/src/stages/common/helpers.ml b/src/stages/common/helpers.ml index d498a1712..5dba263b8 100644 --- a/src/stages/common/helpers.ml +++ b/src/stages/common/helpers.ml @@ -28,6 +28,8 @@ let bind_fold_lmap f init (lmap:_ LMap.t) = let bind_map_lmap f map = bind_lmap (LMap.map f map) let bind_map_cmap f map = bind_cmap (CMap.map f map) +let bind_map_lmapi f map = bind_lmap (LMap.mapi f map) +let bind_map_cmapi f map = bind_cmap (CMap.mapi f map) let range i j = let rec aux i j acc = if i >= j then acc else aux i (j-1) (j-1 :: acc) in diff --git a/src/stages/common/helpers.mli b/src/stages/common/helpers.mli index 69efa24eb..d5e388e36 100644 --- a/src/stages/common/helpers.mli +++ b/src/stages/common/helpers.mli @@ -19,3 +19,12 @@ 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 bind_map_lmapi : + (Types.label -> 'a -> ('b * 'c list, 'd) result) -> + 'a Types.label_map -> ('b Types.label_map * 'c list, 'd) result +val bind_map_cmapi : + (Types.constructor' -> 'a -> ('b * 'c list, 'd) result) -> + 'a Types.constructor_map -> ('b Types.constructor_map * 'c list, 'd) result From 5a15feadc157f1f87a44408643069f46d33e02e0 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 21 Feb 2020 17:07:48 +0100 Subject: [PATCH 2/4] now map over type declarations --- .../entrypoints_lenght_limit.ml | 25 +++++++ src/passes/3-self_ast_simplified/helpers.ml | 71 ++++++++++++++++--- .../self_ast_simplified.ml | 15 ++-- 3 files changed, 99 insertions(+), 12 deletions(-) create mode 100644 src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml diff --git a/src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml b/src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml new file mode 100644 index 000000000..a64007b4a --- /dev/null +++ b/src/passes/3-self_ast_simplified/entrypoints_lenght_limit.ml @@ -0,0 +1,25 @@ +open Ast_simplified +open Trace +open Stage_common.Helpers + +module Errors = struct + let bad_string_timestamp name () = + let title = thunk @@ Format.asprintf ("Too long constructor '%s'") name in + let message () = "names length is limited to 32 (tezos limitation)" in + error title message () +end +open Errors + +let peephole_type_expression : type_expression -> type_expression result = fun e -> + let return type_content = ok { e with type_content } in + match e.type_content with + | T_sum cmap -> + let%bind _uu = bind_map_cmapi + (fun k _ -> + let (Constructor name) = k in + if (String.length name >= 32) then fail @@ bad_string_timestamp name + else ok () + ) + cmap in + ok e + | e -> return e diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index 40520a0f4..f34f48514 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -90,8 +90,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m -> ok res ) -type mapper = expression -> expression result -let rec map_expression : mapper -> expression -> expression result = fun f e -> +type exp_mapper = expression -> expression result +type ty_exp_mapper = type_expression -> type_expression result +type abs_mapper = + | Expression of exp_mapper + | Type_expression of ty_exp_mapper +let rec map_expression : exp_mapper -> expression -> expression result = fun f e -> let self = map_expression f in let%bind e' = f e in let return expression_content = ok { e' with expression_content } in @@ -167,8 +171,54 @@ let rec map_expression : mapper -> expression -> expression result = fun f e -> ) | 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 + match te'.type_content with + | T_sum temap -> + let%bind temap' = bind_map_cmap self temap in + return @@ (T_sum temap') + | T_record temap -> + let%bind temap' = bind_map_lmap self temap in + return @@ (T_record temap') + | T_arrow {type1 ; type2} -> + let%bind type1' = self type1 in + let%bind type2' = self type2 in + return @@ (T_arrow {type1=type1' ; type2=type2'}) + | T_operator type_op -> + let%bind to' = map_type_operator f type_op in + return @@ (T_operator to') + | T_variable _ | T_constant _ -> ok te' -and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> +and map_type_operator : ty_exp_mapper -> type_operator -> type_operator result = fun f te -> + match te with + | TC_contract e -> + let%bind e' = map_type_expression f e in + ok @@ TC_contract e' + | TC_option e -> + let%bind e' = map_type_expression f e in + ok @@ TC_option e' + | TC_list e -> + let%bind e' = map_type_expression f e in + ok @@ TC_list e' + | TC_set e -> + let%bind e' = map_type_expression f e in + ok @@ TC_set e' + | TC_map (a , b) -> + let%bind a' = map_type_expression f a in + let%bind b' = map_type_expression f b in + ok @@ TC_map (a' , b') + | TC_big_map (a , b) -> + let%bind a' = map_type_expression f a in + let%bind b' = map_type_expression f b in + ok @@ TC_big_map (a' , b') + | TC_arrow (a , b) -> + let%bind a' = map_type_expression f a in + let%bind b' = map_type_expression f b in + ok @@ TC_arrow (a' , b') + +and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> match m with | Match_bool { match_true ; match_false } -> ( let%bind match_true = map_expression f match_true in @@ -198,14 +248,19 @@ and map_cases : mapper -> matching_expr -> matching_expr result = fun f m -> ok @@ Match_variant (lst', ()) ) -and map_program : mapper -> program -> program result = fun m p -> +and map_program : abs_mapper -> program -> program result = fun m p -> let aux = fun (x : declaration) -> - match x with - | Declaration_constant (t , o , i, e) -> ( - let%bind e' = map_expression m e in + match x,m with + | (Declaration_constant (t , o , i, e), Expression m') -> ( + let%bind e' = map_expression m' e in ok (Declaration_constant (t , o , i, e')) ) - | Declaration_type _ -> ok x + | (Declaration_type (tv,te), Type_expression m') -> ( + let%bind te' = map_type_expression m' te in + ok (Declaration_type (tv, te')) + ) + | decl,_ -> ok decl + (* | Declaration_type of (type_variable * type_expression) *) in bind_map_list (bind_map_location aux) p diff --git a/src/passes/3-self_ast_simplified/self_ast_simplified.ml b/src/passes/3-self_ast_simplified/self_ast_simplified.ml index 8f8eee099..a10968c0c 100644 --- a/src/passes/3-self_ast_simplified/self_ast_simplified.ml +++ b/src/passes/3-self_ast_simplified/self_ast_simplified.ml @@ -1,17 +1,24 @@ open Trace -let all = [ +let all_expression_mapper = [ Tezos_type_annotation.peephole_expression ; None_variant.peephole_expression ; Literals.peephole_expression ; ] +let all_type_expression_mapper = [ + Entrypoints_lenght_limit.peephole_type_expression ; +] + +let all_exp = List.map (fun el -> Helpers.Expression el) all_expression_mapper +let all_ty = List.map (fun el -> Helpers.Type_expression el) all_type_expression_mapper let all_program = - let all_p = List.map Helpers.map_program all in - bind_chain all_p + let all_p = List.map Helpers.map_program all_exp in + let all_p2 = List.map Helpers.map_program all_ty in + bind_chain (List.append all_p all_p2) let all_expression = - let all_p = List.map Helpers.map_expression all in + let all_p = List.map Helpers.map_expression all_expression_mapper in bind_chain all_p let map_expression = Helpers.map_expression From 503d8f771e3a7141047bc2d97c1156b513f3a0a5 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 21 Feb 2020 17:08:10 +0100 Subject: [PATCH 3/4] add tests for sum type names limit length --- src/bin/expect_tests/contract_tests.ml | 13 +++++++++++++ .../negative/long_sum_type_names.ligo | 18 ++++++++++++++++++ 2 files changed, 31 insertions(+) create mode 100644 src/test/contracts/negative/long_sum_type_names.ligo diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index 49b1563d7..cb7095651 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1139,6 +1139,19 @@ let%expect_test _ = storage (pair (map %one key_hash nat) (big_map %two key_hash bool)) ; code { DUP ; CDR ; NIL operation ; PAIR ; DIP { DROP } } } |}] +let%expect_test _ = + run_ligo_bad [ "compile-contract" ; bad_contract "long_sum_type_names.ligo" ; "main" ] ; + [%expect {| + ligo: Too long constructor 'Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt': names length is limited to 32 (tezos limitation) + + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/what-and-why/ + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}] + let%expect_test _ = run_ligo_good [ "dry-run" ; contract "super-counter.mligo" ; "main" ; "test_param" ; "test_storage" ] ; [%expect {| diff --git a/src/test/contracts/negative/long_sum_type_names.ligo b/src/test/contracts/negative/long_sum_type_names.ligo new file mode 100644 index 000000000..71c9a4efe --- /dev/null +++ b/src/test/contracts/negative/long_sum_type_names.ligo @@ -0,0 +1,18 @@ +type action is +| Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt of int +// | Increment of int +| Decrement of int + +function add (const a : int ; const b : int) : int is a + b + +function subtract (const a : int ; const b : int) : int is a - b + +function main (const p : action ; const s : int) : (list(operation) * int) is + ((nil : list(operation)), + case p of + | Incrementttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt (n) -> add (s, n) + // | Increment(n) -> add (s, n) + | Decrement (n) -> subtract (s, n) + end) + +// incrementttttttttttttttttttttttt \ No newline at end of file From 66aca916bf2f50911c75f3f9279a2075f0b6c254 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 21 Feb 2020 17:18:51 +0100 Subject: [PATCH 4/4] mapping over type_operator types is useless --- src/bin/expect_tests/contract_tests.ml | 4 +-- src/passes/3-self_ast_simplified/helpers.ml | 31 +-------------------- 2 files changed, 3 insertions(+), 32 deletions(-) diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index cb7095651..49d0d9ae1 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1174,7 +1174,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 : ( nat * string ):Some(( nat * string ))) : None return let rhs#808 = #P in let p = rhs#808.0 in let s = rhs#808.1 in ( list[] : (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 : ( nat * string ):Some(( nat * string ))) : None return let rhs#809 = #P in let p = rhs#809.0 in let s = rhs#809.1 in ( list[] : (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"} If you're not sure how to fix this error, you can @@ -1187,7 +1187,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 : ( nat * int ):Some(( nat * int ))) : None return let rhs#811 = #P in let p = rhs#811.0 in let s = rhs#811.1 in ( list[] : (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 : ( nat * int ):Some(( nat * int ))) : None return let rhs#812 = #P in let p = rhs#812.0 in let s = rhs#812.1 in ( list[] : (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"} If you're not sure how to fix this error, you can diff --git a/src/passes/3-self_ast_simplified/helpers.ml b/src/passes/3-self_ast_simplified/helpers.ml index f34f48514..76f884b6a 100644 --- a/src/passes/3-self_ast_simplified/helpers.ml +++ b/src/passes/3-self_ast_simplified/helpers.ml @@ -186,38 +186,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re let%bind type1' = self type1 in let%bind type2' = self type2 in return @@ (T_arrow {type1=type1' ; type2=type2'}) - | T_operator type_op -> - let%bind to' = map_type_operator f type_op in - return @@ (T_operator to') + | T_operator _ | T_variable _ | T_constant _ -> ok te' -and map_type_operator : ty_exp_mapper -> type_operator -> type_operator result = fun f te -> - match te with - | TC_contract e -> - let%bind e' = map_type_expression f e in - ok @@ TC_contract e' - | TC_option e -> - let%bind e' = map_type_expression f e in - ok @@ TC_option e' - | TC_list e -> - let%bind e' = map_type_expression f e in - ok @@ TC_list e' - | TC_set e -> - let%bind e' = map_type_expression f e in - ok @@ TC_set e' - | TC_map (a , b) -> - let%bind a' = map_type_expression f a in - let%bind b' = map_type_expression f b in - ok @@ TC_map (a' , b') - | TC_big_map (a , b) -> - let%bind a' = map_type_expression f a in - let%bind b' = map_type_expression f b in - ok @@ TC_big_map (a' , b') - | TC_arrow (a , b) -> - let%bind a' = map_type_expression f a in - let%bind b' = map_type_expression f b in - ok @@ TC_arrow (a' , b') - and map_cases : exp_mapper -> matching_expr -> matching_expr result = fun f m -> match m with | Match_bool { match_true ; match_false } -> (