From 5a15feadc157f1f87a44408643069f46d33e02e0 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 21 Feb 2020 17:07:48 +0100 Subject: [PATCH] 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