Merge branch '145-entry-point-name-length-limit' into 'dev'

Resolve "Entry point name length limit"

Closes #145

See merge request ligolang/ligo!446

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 {|
@@ -1161,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
@@ -1174,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

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

src/passes/3-self_ast_simplified/helpers.ml

@@ -86,8 +86,12 @@ and fold_cases : 'a folder -> 'a -> matching_expr -> 'a result = fun f init m ->
       ok res
     )
 
-type mapper = expression -> expression result
+type exp_mapper = expression -> expression result
-let rec map_expression : mapper -> expression -> expression result = fun f e ->
+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
@@ -158,8 +162,25 @@ 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 _
+  | T_variable _ | T_constant _ -> ok te'
 
-and map_cases : mapper -> matching_expr -> matching_expr result = fun f m ->
+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
@@ -189,14 +210,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
+    match x,m with
-    | Declaration_constant (t , o , i, e) -> (
+    | (Declaration_constant (t , o , i, e), Expression m') -> (
-        let%bind e' = map_expression m e in
+        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
 

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
+  let all_p = List.map Helpers.map_program all_exp in
-  bind_chain all_p
+  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

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

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

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