diff options
Diffstat (limited to 'lib')
46 files changed, 6495 insertions, 453 deletions
diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index 2def3de7f3..0321b1c07b 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -251,7 +251,9 @@ opt([{set,_,_,{line,_}}=Line1, {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,0}}}=I2|Is]) when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> opt([Line2,I2,Line1,I1|Is]); -opt([{set,Ds0,Ss,Op}|Is0]) -> +opt([{set,[_|_],_Ss,{get_map_elements,_F}}=I|Is]) -> + [I|opt(Is)]; +opt([{set,Ds0,Ss,Op}|Is0]) -> {Ds,Is} = opt_moves(Ds0, Is0), [{set,Ds,Ss,Op}|opt(Is)]; opt([{'%live',_,_}=I|Is]) -> diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index 942d69a756..6004f1974e 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -758,10 +758,20 @@ valfun_4(_, _) -> verify_get_map(Fail, Src, List, Vst0) -> assert_type(map, Src, Vst0), - Vst1 = branch_state(Fail, Vst0), + Vst1 = foldl(fun(D, Vsti) -> + case is_reg_defined(D,Vsti) of + true -> set_type_reg(term,D,Vsti); + false -> Vsti + end + end, Vst0, extract_map_vals(List)), + Vst2 = branch_state(Fail, Vst1), Keys = extract_map_keys(List), assert_unique_map_keys(Keys), - verify_get_map_pair(List,Vst0,Vst1). + verify_get_map_pair(List,Vst0,Vst2). + +extract_map_vals([_Key,Val|T]) -> + [Val|extract_map_vals(T)]; +extract_map_vals([]) -> []. extract_map_keys([Key,_Val|T]) -> [Key|extract_map_keys(T)]; @@ -1093,6 +1103,17 @@ set_catch_end({y,Y}, #vst{current=#st{y=Ys0}=St}=Vst) -> Ys = gb_trees:update(Y, initialized, Ys0), Vst#vst{current=St#st{y=Ys}}. + +is_reg_defined({x,_}=Reg, Vst) -> is_type_defined_x(Reg, Vst); +is_reg_defined({y,_}=Reg, Vst) -> is_type_defined_y(Reg, Vst); +is_reg_defined(V, #vst{}) -> error({not_a_register, V}). + +is_type_defined_x({x,X}, #vst{current=#st{x=Xs}}) -> + gb_trees:is_defined(X,Xs). + +is_type_defined_y({y,Y}, #vst{current=#st{y=Ys}}) -> + gb_trees:is_defined(Y,Ys). + assert_term(Src, Vst) -> get_term_type(Src, Vst), ok. diff --git a/lib/compiler/test/map_SUITE.erl b/lib/compiler/test/map_SUITE.erl index abc12a359d..411b15eebe 100644 --- a/lib/compiler/test/map_SUITE.erl +++ b/lib/compiler/test/map_SUITE.erl @@ -63,7 +63,10 @@ %% errors in 17.0-rc1 t_update_values/1, t_expand_map_update/1, - t_export/1 + t_export/1, + + %% errors in 18 + t_register_corruption/1 ]). suite() -> []. @@ -108,11 +111,13 @@ all() -> t_build_and_match_nil, t_build_and_match_structure, - %% errors in 17.0-rc1 t_update_values, t_expand_map_update, - t_export + t_export, + + %% errors in 18 + t_register_corruption ]. groups() -> []. @@ -1827,6 +1832,53 @@ map_guard_sequence_mixed(K1,K2,M) -> #{ K1 := 1, c := 6, K2 := 8, h := 3} -> 6 end. +%% register corruption discovered in 18 due to +%% get_map_elements might destroys registers when fail-label is taken. +%% Only seen when patterns have two targets, +%% specifically: we copy one register, and then jump. +%% {test,is_map,{f,5},[{x,1}]}. +%% +%% {get_map_elements,{f,7},{x,1},{list,[{atom,a},{x,1},{atom,b},{x,2}]}}. +%% %% if 'a' exists but not 'b' {x,1} is overwritten, jump {f,7} +%% +%% {move,{integer,1},{x,0}}. +%% {call_only,3,{f,10}}. +%% +%% {label,7}. +%% {get_map_elements,{f,8},{x,1},{list,[{atom,b},{x,2}]}}. +%% %% {x,1} (src) is now corrupt +%% +%% {move,{x,0},{x,1}}. +%% {move,{integer,2},{x,0}}. +%% {call_only,3,{f,10}}. +%% +%% Only happens in beam_block opt_move pass with two destinations. + +t_register_corruption(Config) when is_list(Config) -> + M = #{a=> <<"value">>, c=>3}, + {3,wanted,<<"value">>} = register_corruption_bar(M,wanted), + {3,wanted,<<"value">>} = register_corruption_foo(wanted,M), + ok. + +register_corruption_foo(A,#{a := V1, b := V2}) -> + register_corruption_dummy_call(1,V1,V2); +register_corruption_foo(A,#{b := V}) -> + register_corruption_dummy_call(2,A,V); +register_corruption_foo(A,#{a := V}) -> + register_corruption_dummy_call(3,A,V). + +register_corruption_bar(M,A) -> + case M of + #{a := V1, b := V2} -> + register_corruption_dummy_call(1,V1,V2); + #{b := V} -> + register_corruption_dummy_call(2,A,V); + #{a := V} -> + register_corruption_dummy_call(3,A,V) + end. + + +register_corruption_dummy_call(A,B,C) -> {A,B,C}. t_frequency_table(Config) when is_list(Config) -> diff --git a/lib/crypto/src/crypto_ec_curves.erl b/lib/crypto/src/crypto_ec_curves.erl index fe17643d96..002b03b80c 100644 --- a/lib/crypto/src/crypto_ec_curves.erl +++ b/lib/crypto/src/crypto_ec_curves.erl @@ -4,11 +4,13 @@ curves() -> CryptoSupport = crypto:supports(), - HasGF2m = proplists:get_bool(ec_gf2m, proplists:get_value(public_keys, CryptoSupport)), - prime_curves() ++ characteristic_two_curves(HasGF2m). + PubKeys = proplists:get_value(public_keys, CryptoSupport), + HasEC = proplists:get_bool(ecdh, PubKeys), + HasGF2m = proplists:get_bool(ec_gf2m, PubKeys), + prime_curves(HasEC) ++ characteristic_two_curves(HasGF2m). -prime_curves() -> +prime_curves(true) -> [secp112r1,secp112r2,secp128r1,secp128r2,secp160k1,secp160r1,secp160r2, secp192r1,secp192k1,secp224k1,secp224r1,secp256k1,secp256r1,secp384r1, secp521r1,prime192v1,prime192v2,prime192v3,prime239v1,prime239v2,prime239v3, @@ -16,7 +18,9 @@ prime_curves() -> brainpoolP160r1,brainpoolP160t1,brainpoolP192r1,brainpoolP192t1, brainpoolP224r1,brainpoolP224t1,brainpoolP256r1,brainpoolP256t1, brainpoolP320r1,brainpoolP320t1,brainpoolP384r1,brainpoolP384t1, - brainpoolP512r1,brainpoolP512t1]. + brainpoolP512r1,brainpoolP512t1]; +prime_curves(_) -> + []. characteristic_two_curves(true) -> [sect113r1,sect113r2,sect131r1,sect131r2,sect163k1,sect163r1, diff --git a/lib/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src index 6718178fae..8ac6dc1367 100644 --- a/lib/dialyzer/src/dialyzer.app.src +++ b/lib/dialyzer/src/dialyzer.app.src @@ -47,5 +47,5 @@ {applications, [compiler, gs, hipe, kernel, stdlib, wx]}, {env, []}, {runtime_dependencies, ["wx-1.2","syntax_tools-1.6.14","stdlib-2.5", - "kernel-3.0","hipe-3.10.3","erts-7.0", + "kernel-3.0","hipe-3.13","erts-7.0", "compiler-5.0"]}]}. diff --git a/lib/dialyzer/src/dialyzer_cl.erl b/lib/dialyzer/src/dialyzer_cl.erl index 55302d5869..4116866916 100644 --- a/lib/dialyzer/src/dialyzer_cl.erl +++ b/lib/dialyzer/src/dialyzer_cl.erl @@ -547,13 +547,13 @@ hc(Mod, Cache) -> hc_cache(Mod) -> CacheBase = cache_base_dir(), - %% Use HiPE architecture and version in directory name, to avoid - %% clashes between incompatible binaries. + %% Use HiPE architecture, version and erts checksum in directory name, + %% to avoid clashes between incompatible binaries. HipeArchVersion = lists:concat( [erlang:system_info(hipe_architecture), "-", hipe:version(), "-", - hipe_bifs:system_crc()]), + hipe:erts_checksum()]), CacheDir = filename:join(CacheBase, HipeArchVersion), OrigBeamFile = code:which(Mod), {ok, {Mod, <<Checksum:128>>}} = beam_lib:md5(OrigBeamFile), diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_common.hrl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_common.hrl new file mode 100644 index 0000000000..c10626c5cc --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_common.hrl @@ -0,0 +1,55 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Common parts of user and internal header files + + +%%------------------------------------------------------------------------------ +%% Test generation macros +%%------------------------------------------------------------------------------ + +-define(FORALL(X,RawType,Prop), proper:forall(RawType,fun(X) -> Prop end)). +-define(IMPLIES(Pre,Prop), proper:implies(Pre,?DELAY(Prop))). +-define(WHENFAIL(Action,Prop), proper:whenfail(?DELAY(Action),?DELAY(Prop))). +-define(TRAPEXIT(Prop), proper:trapexit(?DELAY(Prop))). +-define(TIMEOUT(Limit,Prop), proper:timeout(Limit,?DELAY(Prop))). +%% TODO: -define(ALWAYS(Tests,Prop), proper:always(Tests,?DELAY(Prop))). +%% TODO: -define(SOMETIMES(Tests,Prop), proper:sometimes(Tests,?DELAY(Prop))). + + +%%------------------------------------------------------------------------------ +%% Generator macros +%%------------------------------------------------------------------------------ + +-define(FORCE(X), (X)()). +-define(DELAY(X), fun() -> X end). +-define(LAZY(X), proper_types:lazy(?DELAY(X))). +-define(SIZED(SizeArg,Gen), proper_types:sized(fun(SizeArg) -> Gen end)). +-define(LET(X,RawType,Gen), proper_types:bind(RawType,fun(X) -> Gen end,false)). +-define(SHRINK(Gen,AltGens), + proper_types:shrinkwith(?DELAY(Gen),?DELAY(AltGens))). +-define(LETSHRINK(Xs,RawType,Gen), + proper_types:bind(RawType,fun(Xs) -> Gen end,true)). +-define(SUCHTHAT(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,true)). +-define(SUCHTHATMAYBE(X,RawType,Condition), + proper_types:add_constraint(RawType,fun(X) -> Condition end,false)). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_gen.erl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_gen.erl new file mode 100644 index 0000000000..bf627d1373 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_gen.erl @@ -0,0 +1,624 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Generator subsystem and generators for basic types. +%%% +%%% You can use <a href="#index">these</a> functions to try out the random +%%% instance generation and shrinking subsystems. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_gen). +-export([pick/1, pick/2, pick/3, sample/1, sample/3, sampleshrink/1, sampleshrink/2]). + +-export([safe_generate/1]). +-export([generate/1, normal_gen/1, alt_gens/1, clean_instance/1, + get_ret_type/1]). +-export([integer_gen/3, float_gen/3, atom_gen/1, atom_rev/1, binary_gen/1, + binary_rev/1, binary_len_gen/1, bitstring_gen/1, bitstring_rev/1, + bitstring_len_gen/1, list_gen/2, distlist_gen/3, vector_gen/2, + union_gen/1, weighted_union_gen/1, tuple_gen/1, loose_tuple_gen/2, + loose_tuple_rev/2, exactly_gen/1, fixed_list_gen/1, function_gen/2, + any_gen/1, native_type_gen/2, safe_weighted_union_gen/1, + safe_union_gen/1]). + +-export_type([instance/0, imm_instance/0, sized_generator/0, nosize_generator/0, + generator/0, reverse_gen/0, combine_fun/0, alt_gens/0]). + +-include("proper_internal.hrl"). + + +%%----------------------------------------------------------------------------- +%% Types +%%----------------------------------------------------------------------------- + +%% TODO: update imm_instance() when adding more types: be careful when reading +%% anything that returns it +%% @private_type +-type imm_instance() :: proper_types:raw_type() + | instance() + | {'$used', imm_instance(), imm_instance()} + | {'$to_part', imm_instance()}. +-type instance() :: term(). +%% A value produced by the random instance generator. +-type error_reason() :: 'arity_limit' | 'cant_generate' | {'typeserver',term()}. + +%% @private_type +-type sized_generator() :: fun((size()) -> imm_instance()). +%% @private_type +-type typed_sized_generator() :: {'typed', + fun((proper_types:type(),size()) -> + imm_instance())}. +%% @private_type +-type nosize_generator() :: fun(() -> imm_instance()). +%% @private_type +-type typed_nosize_generator() :: {'typed', + fun((proper_types:type()) -> + imm_instance())}. +%% @private_type +-type generator() :: sized_generator() + | typed_sized_generator() + | nosize_generator() + | typed_nosize_generator(). +%% @private_type +-type plain_reverse_gen() :: fun((instance()) -> imm_instance()). +%% @private_type +-type typed_reverse_gen() :: {'typed', + fun((proper_types:type(),instance()) -> + imm_instance())}. +%% @private_type +-type reverse_gen() :: plain_reverse_gen() | typed_reverse_gen(). +%% @private_type +-type combine_fun() :: fun((instance()) -> imm_instance()). +%% @private_type +-type alt_gens() :: fun(() -> [imm_instance()]). +%% @private_type +-type fun_seed() :: {non_neg_integer(),non_neg_integer()}. + + +%%----------------------------------------------------------------------------- +%% Instance generation functions +%%----------------------------------------------------------------------------- + +%% @private +-spec safe_generate(proper_types:raw_type()) -> + {'ok',imm_instance()} | {'error',error_reason()}. +safe_generate(RawType) -> + try generate(RawType) of + ImmInstance -> {ok, ImmInstance} + catch + throw:'$arity_limit' -> {error, arity_limit}; + throw:'$cant_generate' -> {error, cant_generate}; + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec generate(proper_types:raw_type()) -> imm_instance(). +generate(RawType) -> + Type = proper_types:cook_outer(RawType), + ok = add_parameters(Type), + Instance = generate(Type, get('$constraint_tries'), none), + ok = remove_parameters(Type), + Instance. + +-spec add_parameters(proper_types:type()) -> 'ok'. +add_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + OldParams = erlang:get('$parameters'), + case OldParams of + undefined -> + erlang:put('$parameters', Params); + _ -> + erlang:put('$parameters', Params ++ OldParams) + end, + ok; + _ -> + ok + end. + +-spec remove_parameters(proper_types:type()) -> 'ok'. +remove_parameters(Type) -> + case proper_types:find_prop(parameters, Type) of + {ok, Params} -> + AllParams = erlang:get('$parameters'), + case AllParams of + Params-> + erlang:erase('$parameters'); + _ -> + erlang:put('$parameters', AllParams -- Params) + end, + ok; + _ -> + ok + end. + +-spec generate(proper_types:type(), non_neg_integer(), + 'none' | {'ok',imm_instance()}) -> imm_instance(). +generate(_Type, 0, none) -> + throw('$cant_generate'); +generate(_Type, 0, {ok,Fallback}) -> + Fallback; +generate(Type, TriesLeft, Fallback) -> + ImmInstance = + case proper_types:get_prop(kind, Type) of + constructed -> + PartsType = proper_types:get_prop(parts_type, Type), + Combine = proper_types:get_prop(combine, Type), + ImmParts = generate(PartsType), + Parts = clean_instance(ImmParts), + ImmInstance1 = Combine(Parts), + %% TODO: We can just generate the internal type: if it's not + %% a type, it will turn into an exactly. + ImmInstance2 = + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end, + {'$used',ImmParts,ImmInstance2}; + _ -> + ImmInstance1 = normal_gen(Type), + case proper_types:is_raw_type(ImmInstance1) of + true -> generate(ImmInstance1); + false -> ImmInstance1 + end + end, + case proper_types:satisfies_all(clean_instance(ImmInstance), Type) of + {_,true} -> ImmInstance; + {true,false} -> generate(Type, TriesLeft - 1, {ok,ImmInstance}); + {false,false} -> generate(Type, TriesLeft - 1, Fallback) + end. + +%% @equiv pick(Type, 10) +-spec pick(Type::proper_types:raw_type()) -> {'ok',instance()} | 'error'. +pick(RawType) -> + pick(RawType, 10). + +%% @equiv pick(Type, Size, now()) +-spec pick(Type::proper_types:raw_type(), size()) -> {'ok', instance()} | 'error'. +pick(RawType, Size) -> + pick(RawType, Size, now()). + +%% @doc Generates a random instance of `Type', of size `Size' with seed `Seed'. +-spec pick(Type::proper_types:raw_type(), size(), seed()) -> + {'ok',instance()} | 'error'. +pick(RawType, Size, Seed) -> + proper:global_state_init_size_seed(Size, Seed), + case clean_instance(safe_generate(RawType)) of + {ok,Instance} = Result -> + Msg = "WARNING: Some garbage has been left in the process registry " + "and the code server~n" + "to allow for the returned function(s) to run normally.~n" + "Please run proper:global_state_erase() when done.~n", + case contains_fun(Instance) of + true -> io:format(Msg, []); + false -> proper:global_state_erase() + end, + Result; + {error,Reason} -> + proper:report_error(Reason, fun io:format/2), + proper:global_state_erase(), + error + end. + +%% @equiv sample(Type, 10, 20) +-spec sample(Type::proper_types:raw_type()) -> 'ok'. +sample(RawType) -> + sample(RawType, 10, 20). + +%% @doc Generates and prints one random instance of `Type' for each size from +%% `StartSize' up to `EndSize'. +-spec sample(Type::proper_types:raw_type(), size(), size()) -> 'ok'. +sample(RawType, StartSize, EndSize) when StartSize =< EndSize -> + Tests = EndSize - StartSize + 1, + Prop = ?FORALL(X, RawType, begin io:format("~p~n",[X]), true end), + Opts = [quiet,{start_size,StartSize},{max_size,EndSize},{numtests,Tests}], + _ = proper:quickcheck(Prop, Opts), + ok. + +%% @equiv sampleshrink(Type, 10) +-spec sampleshrink(Type::proper_types:raw_type()) -> 'ok'. +sampleshrink(RawType) -> + sampleshrink(RawType, 10). + +%% @doc Generates a random instance of `Type', of size `Size', then shrinks it +%% as far as it goes. The value produced on each step of the shrinking process +%% is printed on the screen. +-spec sampleshrink(Type::proper_types:raw_type(), size()) -> 'ok'. +sampleshrink(RawType, Size) -> + proper:global_state_init_size(Size), + Type = proper_types:cook_outer(RawType), + case safe_generate(Type) of + {ok,ImmInstance} -> + Shrunk = keep_shrinking(ImmInstance, [], Type), + PrintInst = fun(I) -> io:format("~p~n",[clean_instance(I)]) end, + lists:foreach(PrintInst, Shrunk); + {error,Reason} -> + proper:report_error(Reason, fun io:format/2) + end, + proper:global_state_erase(), + ok. + +-spec keep_shrinking(imm_instance(), [imm_instance()], proper_types:type()) -> + [imm_instance(),...]. +keep_shrinking(ImmInstance, Acc, Type) -> + case proper_shrink:shrink(ImmInstance, Type, init) of + {[], _NewState} -> + lists:reverse([ImmInstance|Acc]); + {[Shrunk|_Rest], _NewState} -> + keep_shrinking(Shrunk, [ImmInstance|Acc], Type) + end. + +-spec contains_fun(term()) -> boolean(). +contains_fun(List) when is_list(List) -> + proper_arith:safe_any(fun contains_fun/1, List); +contains_fun(Tuple) when is_tuple(Tuple) -> + contains_fun(tuple_to_list(Tuple)); +contains_fun(Fun) when is_function(Fun) -> + true; +contains_fun(_Term) -> + false. + + +%%----------------------------------------------------------------------------- +%% Utility functions +%%----------------------------------------------------------------------------- + +%% @private +-spec normal_gen(proper_types:type()) -> imm_instance(). +normal_gen(Type) -> + case proper_types:get_prop(generator, Type) of + {typed, Gen} -> + if + is_function(Gen, 1) -> Gen(Type); + is_function(Gen, 2) -> Gen(Type, proper:get_size(Type)) + end; + Gen -> + if + is_function(Gen, 0) -> Gen(); + is_function(Gen, 1) -> Gen(proper:get_size(Type)) + end + end. + +%% @private +-spec alt_gens(proper_types:type()) -> [imm_instance()]. +alt_gens(Type) -> + case proper_types:find_prop(alt_gens, Type) of + {ok, AltGens} -> ?FORCE(AltGens); + error -> [] + end. + +%% @private +-spec clean_instance(imm_instance()) -> instance(). +clean_instance({'$used',_ImmParts,ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance({'$to_part',ImmInstance}) -> + clean_instance(ImmInstance); +clean_instance(ImmInstance) -> + if + is_list(ImmInstance) -> + %% CAUTION: this must handle improper lists + proper_arith:safe_map(fun clean_instance/1, ImmInstance); + is_tuple(ImmInstance) -> + proper_arith:tuple_map(fun clean_instance/1, ImmInstance); + true -> + ImmInstance + end. + + +%%----------------------------------------------------------------------------- +%% Basic type generators +%%----------------------------------------------------------------------------- + +%% @private +-spec integer_gen(size(), proper_types:extint(), proper_types:extint()) -> + integer(). +integer_gen(Size, inf, inf) -> + proper_arith:rand_int(Size); +integer_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_int(Size); +integer_gen(Size, Low, High) -> + proper_arith:smart_rand_int(Size, Low, High). + +%% @private +-spec float_gen(size(), proper_types:extnum(), proper_types:extnum()) -> + float(). +float_gen(Size, inf, inf) -> + proper_arith:rand_float(Size); +float_gen(Size, inf, High) -> + High - proper_arith:rand_non_neg_float(Size); +float_gen(Size, Low, inf) -> + Low + proper_arith:rand_non_neg_float(Size); +float_gen(_Size, Low, High) -> + proper_arith:rand_float(Low, High). + +%% @private +-spec atom_gen(size()) -> proper_types:type(). +%% We make sure we never clash with internal atoms by checking that the first +%% character is not '$'. +atom_gen(Size) -> + ?LET(Str, + ?SUCHTHAT(X, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + X =:= [] orelse hd(X) =/= $$), + list_to_atom(Str)). + +%% @private +-spec atom_rev(atom()) -> imm_instance(). +atom_rev(Atom) -> + {'$used', atom_to_list(Atom), Atom}. + +%% @private +-spec binary_gen(size()) -> proper_types:type(). +binary_gen(Size) -> + ?LET(Bytes, + proper_types:resize(Size, + proper_types:list(proper_types:byte())), + list_to_binary(Bytes)). + +%% @private +-spec binary_rev(binary()) -> imm_instance(). +binary_rev(Binary) -> + {'$used', binary_to_list(Binary), Binary}. + +%% @private +-spec binary_len_gen(length()) -> proper_types:type(). +binary_len_gen(Len) -> + ?LET(Bytes, + proper_types:vector(Len, proper_types:byte()), + list_to_binary(Bytes)). + +%% @private +-spec bitstring_gen(size()) -> proper_types:type(). +bitstring_gen(Size) -> + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:resize(Size,proper_types:binary()), + proper_types:range(0,7), proper_types:range(0,127)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec bitstring_rev(bitstring()) -> imm_instance(). +bitstring_rev(BitString) -> + List = bitstring_to_list(BitString), + {BytesList, BitsTail} = lists:splitwith(fun erlang:is_integer/1, List), + {NumBits, TailByte} = case BitsTail of + [] -> {0, 0}; + [Bits] -> N = bit_size(Bits), + <<Byte:N>> = Bits, + {N, Byte} + end, + {'$used', + {{'$used',BytesList,list_to_binary(BytesList)}, NumBits, TailByte}, + BitString}. + +%% @private +-spec bitstring_len_gen(length()) -> proper_types:type(). +bitstring_len_gen(Len) -> + BytesLen = Len div 8, + BitsLen = Len rem 8, + ?LET({BytesHead, NumBits, TailByte}, + {proper_types:binary(BytesLen), BitsLen, + proper_types:range(0, 1 bsl BitsLen - 1)}, + <<BytesHead/binary, TailByte:NumBits>>). + +%% @private +-spec list_gen(size(), proper_types:type()) -> [imm_instance()]. +list_gen(Size, ElemType) -> + Len = proper_arith:rand_int(0, Size), + vector_gen(Len, ElemType). + +%% @private +-spec distlist_gen(size(), sized_generator(), boolean()) -> [imm_instance()]. +distlist_gen(RawSize, Gen, NonEmpty) -> + Len = case NonEmpty of + true -> proper_arith:rand_int(1, erlang:max(1,RawSize)); + false -> proper_arith:rand_int(0, RawSize) + end, + Size = case Len of + 1 -> RawSize - 1; + _ -> RawSize + end, + %% TODO: this produces a lot of types: maybe a simple 'div' is sufficient? + Sizes = proper_arith:distribute(Size, Len), + InnerTypes = [Gen(S) || S <- Sizes], + fixed_list_gen(InnerTypes). + +%% @private +-spec vector_gen(length(), proper_types:type()) -> [imm_instance()]. +vector_gen(Len, ElemType) -> + vector_gen_tr(Len, ElemType, []). + +-spec vector_gen_tr(length(), proper_types:type(), [imm_instance()]) -> + [imm_instance()]. +vector_gen_tr(0, _ElemType, AccList) -> + AccList; +vector_gen_tr(Left, ElemType, AccList) -> + vector_gen_tr(Left - 1, ElemType, [generate(ElemType) | AccList]). + +%% @private +-spec union_gen([proper_types:type(),...]) -> imm_instance(). +union_gen(Choices) -> + {_Choice,Type} = proper_arith:rand_choose(Choices), + generate(Type). + +%% @private +-spec weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +weighted_union_gen(FreqChoices) -> + {_Choice,Type} = proper_arith:freq_choose(FreqChoices), + generate(Type). + +%% @private +-spec safe_union_gen([proper_types:type(),...]) -> imm_instance(). +safe_union_gen(Choices) -> + {Choice,Type} = proper_arith:rand_choose(Choices), + try generate(Type) + catch + error:_ -> + safe_union_gen(proper_arith:list_remove(Choice, Choices)) + end. + +%% @private +-spec safe_weighted_union_gen([{frequency(),proper_types:type()},...]) -> + imm_instance(). +safe_weighted_union_gen(FreqChoices) -> + {Choice,Type} = proper_arith:freq_choose(FreqChoices), + try generate(Type) + catch + error:_ -> + safe_weighted_union_gen(proper_arith:list_remove(Choice, + FreqChoices)) + end. + +%% @private +-spec tuple_gen([proper_types:type()]) -> tuple(). +tuple_gen(Fields) -> + list_to_tuple(fixed_list_gen(Fields)). + +%% @private +-spec loose_tuple_gen(size(), proper_types:type()) -> proper_types:type(). +loose_tuple_gen(Size, ElemType) -> + ?LET(L, + proper_types:resize(Size, proper_types:list(ElemType)), + list_to_tuple(L)). + +%% @private +-spec loose_tuple_rev(tuple(), proper_types:type()) -> imm_instance(). +loose_tuple_rev(Tuple, ElemType) -> + CleanList = tuple_to_list(Tuple), + List = case proper_types:find_prop(reverse_gen, ElemType) of + {ok,{typed, ReverseGen}} -> + [ReverseGen(ElemType,X) || X <- CleanList]; + {ok,ReverseGen} -> [ReverseGen(X) || X <- CleanList]; + error -> CleanList + end, + {'$used', List, Tuple}. + +%% @private +-spec exactly_gen(T) -> T. +exactly_gen(X) -> + X. + +%% @private +-spec fixed_list_gen([proper_types:type()]) -> imm_instance() + ; ({[proper_types:type()],proper_types:type()}) -> + maybe_improper_list(imm_instance(), imm_instance() | []). +fixed_list_gen({ProperHead,ImproperTail}) -> + [generate(F) || F <- ProperHead] ++ generate(ImproperTail); +fixed_list_gen(ProperFields) -> + [generate(F) || F <- ProperFields]. + +%% @private +-spec function_gen(arity(), proper_types:type()) -> function(). +function_gen(Arity, RetType) -> + FunSeed = {proper_arith:rand_int(0, ?SEED_RANGE - 1), + proper_arith:rand_int(0, ?SEED_RANGE - 1)}, + create_fun(Arity, RetType, FunSeed). + +%% @private +-spec any_gen(size()) -> imm_instance(). +any_gen(Size) -> + case get('$any_type') of + undefined -> real_any_gen(Size); + {type,AnyType} -> generate(proper_types:resize(Size, AnyType)) + end. + +-spec real_any_gen(size()) -> imm_instance(). +real_any_gen(0) -> + SimpleTypes = [proper_types:integer(), proper_types:float(), + proper_types:atom()], + union_gen(SimpleTypes); +real_any_gen(Size) -> + FreqChoices = [{?ANY_SIMPLE_PROB,simple}, {?ANY_BINARY_PROB,binary}, + {?ANY_EXPAND_PROB,expand}], + case proper_arith:freq_choose(FreqChoices) of + {_,simple} -> + real_any_gen(0); + {_,binary} -> + generate(proper_types:resize(Size, proper_types:bitstring())); + {_,expand} -> + %% TODO: statistics of produced terms? + NumElems = proper_arith:rand_int(0, Size - 1), + ElemSizes = proper_arith:distribute(Size - 1, NumElems), + ElemTypes = [?LAZY(real_any_gen(S)) || S <- ElemSizes], + case proper_arith:rand_int(1,2) of + 1 -> fixed_list_gen(ElemTypes); + 2 -> tuple_gen(ElemTypes) + end + end. + +%% @private +-spec native_type_gen(mod_name(), string()) -> proper_types:type(). +native_type_gen(Mod, TypeStr) -> + case proper_typeserver:translate_type({Mod,TypeStr}) of + {ok,Type} -> Type; + {error,Reason} -> throw({'$typeserver',Reason}) + end. + + +%%------------------------------------------------------------------------------ +%% Function-generation functions +%%------------------------------------------------------------------------------ + +-spec create_fun(arity(), proper_types:type(), fun_seed()) -> function(). +create_fun(Arity, RetType, FunSeed) -> + Handler = fun(Args) -> function_body(Args, RetType, FunSeed) end, + Err = fun() -> throw('$arity_limit') end, + case Arity of + 0 -> fun() -> Handler([]) end; + _ -> Err() + end. + +%% @private +-spec get_ret_type(function()) -> proper_types:type(). +get_ret_type(Fun) -> + {arity,Arity} = erlang:fun_info(Fun, arity), + put('$get_ret_type', true), + RetType = apply(Fun, lists:duplicate(Arity,dummy)), + erase('$get_ret_type'), + RetType. +-spec function_body([term()], proper_types:type(), fun_seed()) -> + proper_types:type() | instance(). +function_body(Args, RetType, {Seed1,Seed2}) -> + case get('$get_ret_type') of + true -> + RetType; + _ -> + SavedSeed = get(?SEED_NAME), + update_seed({Seed1,Seed2,erlang:phash2(Args,?SEED_RANGE)}), + Ret = clean_instance(generate(RetType)), + put(?SEED_NAME, SavedSeed), + proper_symb:internal_eval(Ret) + end. + +-ifdef(USE_SFMT). +update_seed(Seed) -> + sfmt:seed(Seed). +-else. +update_seed(Seed) -> + put(random_seed, Seed). +-endif. diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_internal.hrl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_internal.hrl new file mode 100644 index 0000000000..c790d7d4db --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_internal.hrl @@ -0,0 +1,92 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis +%%% @doc Internal header file: This header is included in all PropEr source +%%% files. + +-include("proper_common.hrl"). + + +%%------------------------------------------------------------------------------ +%% Activate strip_types parse transform +%%------------------------------------------------------------------------------ + +-ifdef(NO_TYPES). +-compile({parse_transform, strip_types}). +-endif. + +%%------------------------------------------------------------------------------ +%% Random generator selection +%%------------------------------------------------------------------------------ + +-ifdef(USE_SFMT). +-define(RANDOM_MOD, sfmt). +-define(SEED_NAME, sfmt_seed). +-else. +-define(RANDOM_MOD, random). +-define(SEED_NAME, random_seed). +-endif. + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(PROPERTY_PREFIX, "prop_"). + + +%%------------------------------------------------------------------------------ +%% Constants +%%------------------------------------------------------------------------------ + +-define(SEED_RANGE, 4294967296). +-define(MAX_ARITY, 20). +-define(MAX_TRIES_FACTOR, 5). +-define(ANY_SIMPLE_PROB, 3). +-define(ANY_BINARY_PROB, 1). +-define(ANY_EXPAND_PROB, 8). +-define(SMALL_RANGE_THRESHOLD, 16#FFFF). + + +%%------------------------------------------------------------------------------ +%% Common type aliases +%%------------------------------------------------------------------------------ + +%% TODO: Perhaps these should be moved inside modules. +-type mod_name() :: atom(). +-type fun_name() :: atom(). +-type size() :: non_neg_integer(). +-type length() :: non_neg_integer(). +-type position() :: pos_integer(). +-type frequency() :: pos_integer(). +-type seed() :: {non_neg_integer(), non_neg_integer(), non_neg_integer()}. + +-type abs_form() :: erl_parse:abstract_form(). +-type abs_expr() :: erl_parse:abstract_expr(). +-type abs_clause() :: erl_parse:abstract_clause(). + +%% TODO: Replace these with the appropriate types from stdlib. +-type abs_type() :: term(). +-type abs_rec_field() :: term(). + +-type loose_tuple(T) :: {} | {T} | {T,T} | {T,T,T} | {T,T,T,T} | {T,T,T,T,T} + | {T,T,T,T,T,T} | {T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T} + | {T,T,T,T,T,T,T,T,T} | {T,T,T,T,T,T,T,T,T,T} | tuple(). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_types.erl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_types.erl new file mode 100644 index 0000000000..fe83a0ba11 --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_types.erl @@ -0,0 +1,1349 @@ +%%% Copyright 2010-2013 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2013 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Type manipulation functions and predefined types. +%%% +%%% == Basic types == +%%% This module defines all the basic types of the PropEr type system as +%%% functions. See the <a href="#index">function index</a> for an overview. +%%% +%%% Types can be combined in tuples or lists to produce other types. Exact +%%% values (such as exact numbers, atoms, binaries and strings) can be combined +%%% with types inside such structures, like in this example of the type of a +%%% tagged tuple: ``{'result', integer()}''. +%%% +%%% When including the PropEr header file, all +%%% <a href="#index">API functions</a> of this module are automatically +%%% imported, unless `PROPER_NO_IMPORTS' is defined. +%%% +%%% == Customized types == +%%% The following operators can be applied to basic types in order to produce +%%% new ones: +%%% +%%% <dl> +%%% <dt>`?LET(<Xs>, <Xs_type>, <In>)'</dt> +%%% <dd>To produce an instance of this type, all appearances of the variables +%%% in `<Xs>' are replaced inside `<In>' by their corresponding values in a +%%% randomly generated instance of `<Xs_type>'. It's OK for the `<In>' part to +%%% evaluate to a type - in that case, an instance of the inner type is +%%% generated recursively.</dd> +%%% <dt>`?SUCHTHAT(<X>, <Type>, <Condition>)'</dt> +%%% <dd>This produces a specialization of `<Type>', which only includes those +%%% members of `<Type>' that satisfy the constraint `<Condition>' - that is, +%%% those members for which the function `fun(<X>) -> <Condition> end' returns +%%% `true'. If the constraint is very strict - that is, only a small +%%% percentage of instances of `<Type>' pass the test - it will take a lot of +%%% tries for the instance generation subsystem to randomly produce a valid +%%% instance. This will result in slower testing, and testing may even be +%%% stopped short, in case the `constraint_tries' limit is reached (see the +%%% "Options" section in the documentation of the {@link proper} module). If +%%% this is the case, it would be more appropriate to generate valid instances +%%% of the specialized type using the `?LET' macro. Also make sure that even +%%% small instances can satisfy the constraint, since PropEr will only try +%%% small instances at the start of testing. If this is not possible, you can +%%% instruct PropEr to start at a larger size, by supplying a suitable value +%%% for the `start_size' option (see the "Options" section in the +%%% documentation of the {@link proper} module).</dd> +%%% <dt>`?SUCHTHATMAYBE(<X>, <Type>, <Condition>)'</dt> +%%% <dd>Equivalent to the `?SUCHTHAT' macro, but the constraint `<Condition>' +%%% is considered non-strict: if the `constraint_tries' limit is reached, the +%%% generator will just return an instance of `<Type>' instead of failing, +%%% even if that instance doesn't satisfy the constraint.</dd> +%%% <dt>`?SHRINK(<Generator>, <List_of_alt_gens>)'</dt> +%%% <dd>This creates a type whose instances are generated by evaluating the +%%% statement block `<Generator>' (this may evaluate to a type, which will +%%% then be generated recursively). If an instance of such a type is to be +%%% shrunk, the generators in `<List_of_alt_gens>' are first run to produce +%%% hopefully simpler instances of the type. Thus, the generators in the +%%% second argument should be simpler than the default. The simplest ones +%%% should be at the front of the list, since those are the generators +%%% preferred by the shrinking subsystem. Like the main `<Generator>', the +%%% alternatives may also evaluate to a type, which is generated recursively. +%%% </dd> +%%% <dt>`?LETSHRINK(<List_of_variables>, <List_of_types>, <Generator>)'</dt> +%%% <dd>This is created by combining a `?LET' and a `?SHRINK' macro. Instances +%%% are generated by applying a randomly generated list of values inside +%%% `<Generator>' (just like a `?LET', with the added constraint that the +%%% variables and types must be provided in a list - alternatively, +%%% `<List_of_types>' may be a list or vector type). When shrinking instances +%%% of such a type, the sub-instances that were combined to produce it are +%%% first tried in place of the failing instance.</dd> +%%% <dt>`?LAZY(<Generator>)'</dt> +%%% <dd>This construct returns a type whose only purpose is to delay the +%%% evaluation of `<Generator>' (`<Generator>' can return a type, which will +%%% be generated recursively). Using this, you can simulate the lazy +%%% generation of instances: +%%% ``` stream() -> ?LAZY(frequency([ {1,[]}, {3,[0|stream()]} ])). ''' +%%% The above type produces lists of zeroes with an average length of 3. Note +%%% that, had we not enclosed the generator with a `?LAZY' macro, the +%%% evaluation would continue indefinitely, due to the eager evaluation of +%%% the Erlang language.</dd> +%%% <dt>`non_empty(<List_or_binary_type>)'</dt> +%%% <dd>See the documentation for {@link non_empty/1}.</dd> +%%% <dt>`noshrink(<Type>)'</dt> +%%% <dd>See the documentation for {@link noshrink/1}.</dd> +%%% <dt>`default(<Default_value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link default/2}.</dd> +%%% <dt>`with_parameter(<Parameter>, <Value>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameter/3}.</dd> +%%% <dt>`with_parameters(<Param_value_pairs>, <Type>)'</dt> +%%% <dd>See the documentation for {@link with_parameters/2}.</dd> +%%% </dl> +%%% +%%% == Size manipulation == +%%% The following operators are related to the `size' parameter, which controls +%%% the maximum size of produced instances. The actual size of a produced +%%% instance is chosen randomly, but can never exceed the value of the `size' +%%% parameter at the moment of generation. A more accurate definition is the +%%% following: the maximum instance of `size S' can never be smaller than the +%%% maximum instance of `size S-1'. The actual size of an instance is measured +%%% differently for each type: the actual size of a list is its length, while +%%% the actual size of a tree may be the number of its internal nodes. Some +%%% types, e.g. unions, have no notion of size, thus their generation is not +%%% influenced by the value of `size'. The `size' parameter starts at 1 and +%%% grows automatically during testing. +%%% +%%% <dl> +%%% <dt>`?SIZED(<S>, <Generator>)'</dt> +%%% <dd>Creates a new type, whose instances are produced by replacing all +%%% appearances of the `<S>' parameter inside the statement block +%%% `<Generator>' with the value of the `size' parameter. It's OK for the +%%% `<Generator>' to return a type - in that case, an instance of the inner +%%% type is generated recursively.</dd> +%%% <dt>`resize(<New_size>, <Type>)'</dt> +%%% <dd>See the documentation for {@link resize/2}.</dd> +%%% </dl> + +-module(proper_types). +-export([is_inst/2, is_inst/3]). + +-export([integer/2, float/2, atom/0, binary/0, binary/1, bitstring/0, + bitstring/1, list/1, vector/2, union/1, weighted_union/1, tuple/1, + loose_tuple/1, exactly/1, fixed_list/1, function/2, any/0, + shrink_list/1, safe_union/1, safe_weighted_union/1]). +-export([integer/0, non_neg_integer/0, pos_integer/0, neg_integer/0, range/2, + float/0, non_neg_float/0, number/0, boolean/0, byte/0, char/0, + list/0, tuple/0, string/0, wunion/1, term/0, timeout/0, arity/0]). +-export([int/0, nat/0, largeint/0, real/0, bool/0, choose/2, elements/1, + oneof/1, frequency/1, return/1, default/2, orderedlist/1, function0/1, + function1/1, function2/1, function3/1, function4/1, + weighted_default/2]). +-export([resize/2, non_empty/1, noshrink/1]). + +-export([cook_outer/1, is_type/1, equal_types/2, is_raw_type/1, to_binary/1, + from_binary/1, get_prop/2, find_prop/2, safe_is_instance/2, + is_instance/2, unwrap/1, weakly/1, strongly/1, satisfies_all/2, + new_type/2, subtype/2]). +-export([lazy/1, sized/1, bind/3, shrinkwith/2, add_constraint/3, + native_type/2, distlist/3, with_parameter/3, with_parameters/2, + parameter/1, parameter/2]). +-export([le/2]). + +-export_type([type/0, raw_type/0, extint/0, extnum/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Comparison with erl_types +%%------------------------------------------------------------------------------ + +%% Missing types +%% ------------------- +%% will do: +%% records, maybe_improper_list(T,S), nonempty_improper_list(T,S) +%% maybe_improper_list(), maybe_improper_list(T), iolist, iodata +%% don't need: +%% nonempty_{list,string,maybe_improper_list} +%% won't do: +%% pid, port, ref, identifier, none, no_return, module, mfa, node +%% array, dict, digraph, set, gb_tree, gb_set, queue, tid + +%% Missing type information +%% ------------------------ +%% bin types: +%% other unit sizes? what about size info? +%% functions: +%% generally some fun, unspecified number of arguments but specified +%% return type +%% any: +%% doesn't cover functions and improper lists + + +%%------------------------------------------------------------------------------ +%% Type declaration macros +%%------------------------------------------------------------------------------ + +-define(BASIC(PropList), new_type(PropList,basic)). +-define(WRAPPER(PropList), new_type(PropList,wrapper)). +-define(CONSTRUCTED(PropList), new_type(PropList,constructed)). +-define(CONTAINER(PropList), new_type(PropList,container)). +-define(SUBTYPE(Type,PropList), subtype(PropList,Type)). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_kind() :: 'basic' | 'wrapper' | 'constructed' | 'container' | atom(). +-type instance_test() :: fun((proper_gen:imm_instance()) -> boolean()) + | {'typed', + fun((proper_types:type(), + proper_gen:imm_instance()) -> boolean())}. +-type index() :: pos_integer(). +%% @alias +-type value() :: term(). +%% @private_type +%% @alias +-type extint() :: integer() | 'inf'. +%% @private_type +%% @alias +-type extnum() :: number() | 'inf'. +-type constraint_fun() :: fun((proper_gen:instance()) -> boolean()). + +-opaque type() :: {'$type', [type_prop()]}. +%% A type of the PropEr type system +%% @type raw_type(). You can consider this as an equivalent of {@type type()}. +-type raw_type() :: type() | [raw_type()] | loose_tuple(raw_type()) | term(). +-type type_prop_name() :: 'kind' | 'generator' | 'reverse_gen' | 'parts_type' + | 'combine' | 'alt_gens' | 'shrink_to_parts' + | 'size_transform' | 'is_instance' | 'shrinkers' + | 'noshrink' | 'internal_type' | 'internal_types' + | 'get_length' | 'split' | 'join' | 'get_indices' + | 'remove' | 'retrieve' | 'update' | 'constraints' + | 'parameters' | 'env' | 'subenv'. + +-type type_prop_value() :: term(). +-type type_prop() :: + {'kind', type_kind()} + | {'generator', proper_gen:generator()} + | {'reverse_gen', proper_gen:reverse_gen()} + | {'parts_type', type()} + | {'combine', proper_gen:combine_fun()} + | {'alt_gens', proper_gen:alt_gens()} + | {'shrink_to_parts', boolean()} + | {'size_transform', fun((size()) -> size())} + | {'is_instance', instance_test()} + | {'shrinkers', [proper_shrink:shrinker()]} + | {'noshrink', boolean()} + | {'internal_type', raw_type()} + | {'internal_types', tuple() | maybe_improper_list(type(),type() | [])} + %% The items returned by 'remove' must be of this type. + | {'get_length', fun((proper_gen:imm_instance()) -> length())} + %% If this is a container type, this should return the number of elements + %% it contains. + | {'split', fun((proper_gen:imm_instance()) -> [proper_gen:imm_instance()]) + | fun((length(),proper_gen:imm_instance()) -> + {proper_gen:imm_instance(),proper_gen:imm_instance()})} + %% If present, the appropriate form depends on whether get_length is + %% defined: if get_length is undefined, this must be in the one-argument + %% form (e.g. a tree should be split into its subtrees), else it must be + %% in the two-argument form (e.g. a list should be split in two at the + %% index provided). + | {'join', fun((proper_gen:imm_instance(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'get_indices', fun((proper_types:type(), + proper_gen:imm_instance()) -> [index()])} + %% If this is a container type, this should return a list of indices we + %% can use to remove or insert elements from the given instance. + | {'remove', fun((index(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'retrieve', fun((index(), proper_gen:imm_instance() | tuple() + | maybe_improper_list(type(),type() | [])) -> + value() | type())} + | {'update', fun((index(),value(),proper_gen:imm_instance()) -> + proper_gen:imm_instance())} + | {'constraints', [{constraint_fun(), boolean()}]} + %% A list of constraints on instances of this type: each constraint is a + %% tuple of a fun that must return 'true' for each valid instance and a + %% boolean field that specifies whether the condition is strict. + | {'parameters', [{atom(),value()}]} + | {'env', term()} + | {'subenv', term()}. + + +%%------------------------------------------------------------------------------ +%% Type manipulation functions +%%------------------------------------------------------------------------------ + +%% TODO: We shouldn't need the fully qualified type name in the range of these +%% functions. + +%% @private +%% TODO: just cook/1 ? +-spec cook_outer(raw_type()) -> proper_types:type(). +cook_outer(Type = {'$type',_Props}) -> + Type; +cook_outer(RawType) -> + if + is_tuple(RawType) -> tuple(tuple_to_list(RawType)); + %% CAUTION: this must handle improper lists + is_list(RawType) -> fixed_list(RawType); + %% default case (covers integers, floats, atoms, binaries, ...): + true -> exactly(RawType) + end. + +%% @private +-spec is_type(term()) -> boolean(). +is_type({'$type',_Props}) -> + true; +is_type(_) -> + false. + +%% @private +-spec equal_types(proper_types:type(), proper_types:type()) -> boolean(). +equal_types(SameType, SameType) -> + true; +equal_types(_, _) -> + false. + +%% @private +-spec is_raw_type(term()) -> boolean(). +is_raw_type({'$type',_TypeProps}) -> + true; +is_raw_type(X) -> + if + is_tuple(X) -> is_raw_type_list(tuple_to_list(X)); + is_list(X) -> is_raw_type_list(X); + true -> false + end. + +-spec is_raw_type_list(maybe_improper_list()) -> boolean(). +%% CAUTION: this must handle improper lists +is_raw_type_list(List) -> + proper_arith:safe_any(fun is_raw_type/1, List). + +%% @private +-spec to_binary(proper_types:type()) -> binary(). +to_binary(Type) -> + term_to_binary(Type). + +%% @private +%% TODO: restore: -spec from_binary(binary()) -> proper_types:type(). +from_binary(Binary) -> + binary_to_term(Binary). + +-spec type_from_list([type_prop()]) -> proper_types:type(). +type_from_list(KeyValueList) -> + {'$type',KeyValueList}. + +-spec add_prop(type_prop_name(), type_prop_value(), proper_types:type()) -> + proper_types:type(). +add_prop(PropName, Value, {'$type',Props}) -> + {'$type',lists:keystore(PropName, 1, Props, {PropName, Value})}. + +-spec add_props([type_prop()], proper_types:type()) -> proper_types:type(). +add_props(PropList, {'$type',OldProps}) -> + {'$type', lists:foldl(fun({N,_}=NV,Acc) -> + lists:keystore(N, 1, Acc, NV) + end, OldProps, PropList)}. + +-spec append_to_prop(type_prop_name(), type_prop_value(), + proper_types:type()) -> proper_types:type(). +append_to_prop(PropName, Value, {'$type',Props}) -> + Val = case lists:keyfind(PropName, 1, Props) of + {PropName, V} -> + V; + _ -> + [] + end, + {'$type', lists:keystore(PropName, 1, Props, + {PropName, lists:reverse([Value|Val])})}. + +-spec append_list_to_prop(type_prop_name(), [type_prop_value()], + proper_types:type()) -> proper_types:type(). +append_list_to_prop(PropName, List, {'$type',Props}) -> + {PropName, Val} = lists:keyfind(PropName, 1, Props), + {'$type', lists:keystore(PropName, 1, Props, {PropName, Val++List})}. + +%% @private +-spec get_prop(type_prop_name(), proper_types:type()) -> type_prop_value(). +get_prop(PropName, {'$type',Props}) -> + {_PropName, Val} = lists:keyfind(PropName, 1, Props), + Val. + +%% @private +-spec find_prop(type_prop_name(), proper_types:type()) -> + {'ok',type_prop_value()} | 'error'. +find_prop(PropName, {'$type',Props}) -> + case lists:keyfind(PropName, 1, Props) of + {PropName, Value} -> + {ok, Value}; + _ -> + error + end. + +%% @private +-spec new_type([type_prop()], type_kind()) -> proper_types:type(). +new_type(PropList, Kind) -> + Type = type_from_list(PropList), + add_prop(kind, Kind, Type). + +%% @private +-spec subtype([type_prop()], proper_types:type()) -> proper_types:type(). +%% TODO: should the 'is_instance' function etc. be reset for subtypes? +subtype(PropList, Type) -> + add_props(PropList, Type). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType) -> + is_inst(Instance, RawType, 10). + +%% @private +-spec is_inst(proper_gen:instance(), raw_type(), size()) -> + boolean() | {'error',{'typeserver',term()}}. +is_inst(Instance, RawType, Size) -> + proper:global_state_init_size(Size), + Result = safe_is_instance(Instance, RawType), + proper:global_state_erase(), + Result. + +%% @private +-spec safe_is_instance(proper_gen:imm_instance(), raw_type()) -> + boolean() | {'error',{'typeserver',term()}}. +safe_is_instance(ImmInstance, RawType) -> + try is_instance(ImmInstance, RawType) catch + throw:{'$typeserver',SubReason} -> {error, {typeserver,SubReason}} + end. + +%% @private +-spec is_instance(proper_gen:imm_instance(), raw_type()) -> boolean(). +%% TODO: If the second argument is not a type, let it pass (don't even check for +%% term equality?) - if it's a raw type, don't cook it, instead recurse +%% into it. +is_instance(ImmInstance, RawType) -> + CleanInstance = proper_gen:clean_instance(ImmInstance), + Type = cook_outer(RawType), + (case get_prop(kind, Type) of + wrapper -> wrapper_test(ImmInstance, Type); + constructed -> constructed_test(ImmInstance, Type); + _ -> false + end + orelse + case find_prop(is_instance, Type) of + {ok,{typed, IsInstance}} -> IsInstance(Type, ImmInstance); + {ok,IsInstance} -> IsInstance(ImmInstance); + error -> false + end) + andalso weakly(satisfies_all(CleanInstance, Type)). + +-spec wrapper_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +wrapper_test(ImmInstance, Type) -> + %% TODO: check if it's actually a raw type that's returned? + lists:any(fun(T) -> is_instance(ImmInstance, T) end, unwrap(Type)). + +%% @private +%% TODO: restore:-spec unwrap(proper_types:type()) -> [proper_types:type(),...]. +%% TODO: check if it's actually a raw type that's returned? +unwrap(Type) -> + RawInnerTypes = proper_gen:alt_gens(Type) ++ [proper_gen:normal_gen(Type)], + [cook_outer(T) || T <- RawInnerTypes]. + +-spec constructed_test(proper_gen:imm_instance(), proper_types:type()) -> + boolean(). +constructed_test({'$used',ImmParts,ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + Combine = get_prop(combine, Type), + is_instance(ImmParts, PartsType) andalso + begin + %% TODO: check if it's actually a raw type that's returned? + %% TODO: move construction code to proper_gen + %% TODO: non-type => should we check for strict term equality? + RawInnerType = Combine(proper_gen:clean_instance(ImmParts)), + is_instance(ImmInstance, RawInnerType) + end; +constructed_test({'$to_part',ImmInstance}, Type) -> + PartsType = get_prop(parts_type, Type), + get_prop(shrink_to_parts, Type) =:= true andalso + %% TODO: we reject non-container types + get_prop(kind, PartsType) =:= container andalso + case {find_prop(internal_type,PartsType), + find_prop(internal_types,PartsType)} of + {{ok,EachPartType},error} -> + %% The parts are in a list or a vector. + is_instance(ImmInstance, EachPartType); + {error,{ok,PartTypesList}} -> + %% The parts are in a fixed list. + %% TODO: It should always be a proper list. + lists:any(fun(T) -> is_instance(ImmInstance,T) end, PartTypesList) + end; +constructed_test(_CleanInstance, _Type) -> + %% TODO: can we do anything better? + false. + +%% @private +-spec weakly({boolean(),boolean()}) -> boolean(). +weakly({B1,_B2}) -> B1. + +%% @private +-spec strongly({boolean(),boolean()}) -> boolean(). +strongly({_B1,B2}) -> B2. + +-spec satisfies(proper_gen:instance(), {constraint_fun(),boolean()}) + -> {boolean(),boolean()}. +satisfies(Instance, {Test,false}) -> + {true,Test(Instance)}; +satisfies(Instance, {Test,true}) -> + Result = Test(Instance), + {Result,Result}. + +%% @private +-spec satisfies_all(proper_gen:instance(), proper_types:type()) -> + {boolean(),boolean()}. +satisfies_all(Instance, Type) -> + case find_prop(constraints, Type) of + {ok, Constraints} -> + L = [satisfies(Instance, C) || C <- Constraints], + {L1,L2} = lists:unzip(L), + {lists:all(fun(B) -> B end, L1), lists:all(fun(B) -> B end, L2)}; + error -> + {true,true} + end. + + +%%------------------------------------------------------------------------------ +%% Type definition functions +%%------------------------------------------------------------------------------ + +%% @private +-spec lazy(proper_gen:nosize_generator()) -> proper_types:type(). +lazy(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec sized(proper_gen:sized_generator()) -> proper_types:type(). +sized(Gen) -> + ?WRAPPER([ + {generator, Gen} + ]). + +%% @private +-spec bind(raw_type(), proper_gen:combine_fun(), boolean()) -> + proper_types:type(). +bind(RawPartsType, Combine, ShrinkToParts) -> + PartsType = cook_outer(RawPartsType), + ?CONSTRUCTED([ + {parts_type, PartsType}, + {combine, Combine}, + {shrink_to_parts, ShrinkToParts} + ]). + +%% @private +-spec shrinkwith(proper_gen:nosize_generator(), proper_gen:alt_gens()) -> + proper_types:type(). +shrinkwith(Gen, DelaydAltGens) -> + ?WRAPPER([ + {generator, Gen}, + {alt_gens, DelaydAltGens} + ]). + +%% @private +-spec add_constraint(raw_type(), constraint_fun(), boolean()) -> + proper_types:type(). +add_constraint(RawType, Condition, IsStrict) -> + Type = cook_outer(RawType), + append_to_prop(constraints, {Condition,IsStrict}, Type). + +%% @private +-spec native_type(mod_name(), string()) -> proper_types:type(). +native_type(Mod, TypeStr) -> + ?WRAPPER([ + {generator, fun() -> proper_gen:native_type_gen(Mod,TypeStr) end} + ]). + + +%%------------------------------------------------------------------------------ +%% Basic types +%%------------------------------------------------------------------------------ + +%% @doc All integers between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to integers, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0 if `Low =< 0 =< High', or towards the bound with +%% the smallest absolute value otherwise. +-spec integer(extint(), extint()) -> proper_types:type(). +integer(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun integer_gen/2}}, + {is_instance, {typed, fun integer_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +integer_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:integer_gen(Size, Low, High). + +integer_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_integer(X) andalso le(Low, X) andalso le(X, High). + +number_shrinker(X, Type, S) -> + {Low, High} = get_prop(env, Type), + proper_shrink:number_shrinker(X, Low, High, S). + +%% @doc All floats between `Low' and `High', bounds included. +%% `Low' and `High' must be Erlang expressions that evaluate to floats, with +%% `Low =< High'. Additionally, `Low' and `High' may have the value `inf', in +%% which case they represent minus infinity and plus infinity respectively. +%% Instances shrink towards 0.0 if `Low =< 0.0 =< High', or towards the bound +%% with the smallest absolute value otherwise. +-spec float(extnum(), extnum()) -> proper_types:type(). +float(Low, High) -> + ?BASIC([ + {env, {Low, High}}, + {generator, {typed, fun float_gen/2}}, + {is_instance, {typed, fun float_is_instance/2}}, + {shrinkers, [fun number_shrinker/3]} + ]). + +float_gen(Type, Size) -> + {Low, High} = get_prop(env, Type), + proper_gen:float_gen(Size, Low, High). + +float_is_instance(Type, X) -> + {Low, High} = get_prop(env, Type), + is_float(X) andalso le(Low, X) andalso le(X, High). + +%% @private +-spec le(extnum(), extnum()) -> boolean(). +le(inf, _B) -> true; +le(_A, inf) -> true; +le(A, B) -> A =< B. + +%% @doc All atoms. All atoms used internally by PropEr start with a '`$'', so +%% such atoms will never be produced as instances of this type. You should also +%% refrain from using such atoms in your code, to avoid a potential clash. +%% Instances shrink towards the empty atom, ''. +-spec atom() -> proper_types:type(). +atom() -> + ?WRAPPER([ + {generator, fun proper_gen:atom_gen/1}, + {reverse_gen, fun proper_gen:atom_rev/1}, + {size_transform, fun(Size) -> erlang:min(Size,255) end}, + {is_instance, fun atom_is_instance/1} + ]). + +atom_is_instance(X) -> + is_atom(X) + %% We return false for atoms starting with '$', since these are + %% atoms used internally and never produced by the atom generator. + andalso (X =:= '' orelse hd(atom_to_list(X)) =/= $$). + +%% @doc All binaries. Instances shrink towards the empty binary, `<<>>'. +-spec binary() -> proper_types:type(). +binary() -> + ?WRAPPER([ + {generator, fun proper_gen:binary_gen/1}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, fun erlang:is_binary/1} + ]). + +%% @doc All binaries with a byte size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards binaries of zeroes. +-spec binary(length()) -> proper_types:type(). +binary(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun binary_len_gen/1}}, + {reverse_gen, fun proper_gen:binary_rev/1}, + {is_instance, {typed, fun binary_len_is_instance/2}} + ]). + +binary_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:binary_len_gen(Len). + +binary_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_binary(X) andalso byte_size(X) =:= Len. + +%% @doc All bitstrings. Instances shrink towards the empty bitstring, `<<>>'. +-spec bitstring() -> proper_types:type(). +bitstring() -> + ?WRAPPER([ + {generator, fun proper_gen:bitstring_gen/1}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, fun erlang:is_bitstring/1} + ]). + +%% @doc All bitstrings with a bit size of `Len'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +%% Instances shrink towards bitstrings of zeroes +-spec bitstring(length()) -> proper_types:type(). +bitstring(Len) -> + ?WRAPPER([ + {env, Len}, + {generator, {typed, fun bitstring_len_gen/1}}, + {reverse_gen, fun proper_gen:bitstring_rev/1}, + {is_instance, {typed, fun bitstring_len_is_instance/2}} + ]). + +bitstring_len_gen(Type) -> + Len = get_prop(env, Type), + proper_gen:bitstring_len_gen(Len). + +bitstring_len_is_instance(Type, X) -> + Len = get_prop(env, Type), + is_bitstring(X) andalso bit_size(X) =:= Len. + +%% @doc All lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec list(ElemType::raw_type()) -> proper_types:type(). +% TODO: subtyping would be useful here (list, vector, fixed_list) +list(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {generator, {typed, fun list_gen/2}}, + {is_instance, {typed, fun list_is_instance/2}}, + {internal_type, ElemType}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +list_gen(Type, Size) -> + ElemType = get_prop(internal_type, Type), + proper_gen:list_gen(Size, ElemType). + +list_is_instance(Type, X) -> + ElemType = get_prop(internal_type, Type), + list_test(X, ElemType). + +%% @doc A type that generates exactly the list `List'. Instances shrink towards +%% shorter sublists of the original list. +-spec shrink_list([term()]) -> proper_types:type(). +shrink_list(List) -> + ?CONTAINER([ + {env, List}, + {generator, {typed, fun shrink_list_gen/1}}, + {is_instance, {typed, fun shrink_list_is_instance/2}}, + {get_length, fun erlang:length/1}, + {split, fun lists:split/2}, + {join, fun lists:append/2}, + {get_indices, fun list_get_indices/2}, + {remove, fun proper_arith:list_remove/2} + ]). + +shrink_list_gen(Type) -> + get_prop(env, Type). + +shrink_list_is_instance(Type, X) -> + List = get_prop(env, Type), + is_sublist(X, List). + +-spec is_sublist([term()], [term()]) -> boolean(). +is_sublist([], _) -> true; +is_sublist(_, []) -> false; +is_sublist([H|T1], [H|T2]) -> is_sublist(T1, T2); +is_sublist(Slice, [_|T2]) -> is_sublist(Slice, T2). + +-spec list_test(proper_gen:imm_instance(), proper_types:type()) -> boolean(). +list_test(X, ElemType) -> + is_list(X) andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +%% @private +-spec list_get_indices(proper_gen:generator(), list()) -> [position()]. +list_get_indices(_, List) -> + lists:seq(1, length(List)). + +%% @private +%% This assumes that: +%% - instances of size S are always valid instances of size >S +%% - any recursive calls inside Gen are lazy +-spec distlist(size(), proper_gen:sized_generator(), boolean()) -> + proper_types:type(). +distlist(Size, Gen, NonEmpty) -> + ParentType = case NonEmpty of + true -> non_empty(list(Gen(Size))); + false -> list(Gen(Size)) + end, + ?SUBTYPE(ParentType, [ + {subenv, {Size, Gen, NonEmpty}}, + {generator, {typed, fun distlist_gen/1}} + ]). + +distlist_gen(Type) -> + {Size, Gen, NonEmpty} = get_prop(subenv, Type), + proper_gen:distlist_gen(Size, Gen, NonEmpty). + +%% @doc All lists of length `Len' containing elements of type `ElemType'. +%% `Len' must be an Erlang expression that evaluates to a non-negative integer. +-spec vector(length(), ElemType::raw_type()) -> proper_types:type(). +vector(Len, RawElemType) -> + ElemType = cook_outer(RawElemType), + ?CONTAINER([ + {env, Len}, + {generator, {typed, fun vector_gen/1}}, + {is_instance, {typed, fun vector_is_instance/2}}, + {internal_type, ElemType}, + {get_indices, fun vector_get_indices/2}, + {retrieve, fun lists:nth/2}, + {update, fun proper_arith:list_update/3} + ]). + +vector_gen(Type) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + proper_gen:vector_gen(Len, ElemType). + +vector_is_instance(Type, X) -> + Len = get_prop(env, Type), + ElemType = get_prop(internal_type, Type), + is_list(X) + andalso length(X) =:= Len + andalso lists:all(fun(E) -> is_instance(E, ElemType) end, X). + +vector_get_indices(Type, _X) -> + lists:seq(1, get_prop(env, Type)). + +%% @doc The union of all types in `ListOfTypes'. `ListOfTypes' can't be empty. +%% The random instance generator is equally likely to choose any one of the +%% types in `ListOfTypes'. The shrinking subsystem will always try to shrink an +%% instance of a type union to an instance of the first type in `ListOfTypes', +%% thus you should write the simplest case first. +-spec union(ListOfTypes::[raw_type(),...]) -> proper_types:type(). +union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + ?BASIC([ + {env, Choices}, + {generator, {typed, fun union_gen/1}}, + {is_instance, {typed, fun union_is_instance/2}}, + {shrinkers, [fun union_shrinker_1/3, fun union_shrinker_2/3]} + ]). + +union_gen(Type) -> + Choices = get_prop(env,Type), + proper_gen:union_gen(Choices). + +union_is_instance(Type, X) -> + Choices = get_prop(env, Type), + lists:any(fun(C) -> is_instance(X, C) end, Choices). + +union_shrinker_1(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_first_choice_shrinker(X, Choices, S). + +union_shrinker_2(X, Type, S) -> + Choices = get_prop(env, Type), + proper_shrink:union_recursive_shrinker(X, Choices, S). + +%% @doc A specialization of {@link union/1}, where each type in `ListOfTypes' is +%% assigned a frequency. Frequencies must be Erlang expressions that evaluate to +%% positive integers. Types with larger frequencies are more likely to be chosen +%% by the random instance generator. The shrinking subsystem will ignore the +%% frequencies and try to shrink towards the first type in the list. +-spec weighted_union(ListOfTypes::[{frequency(),raw_type()},...]) -> + proper_types:type(). +weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + ?SUBTYPE(union(Choices), [ + {subenv, FreqChoices}, + {generator, {typed, fun weighted_union_gen/1}} + ]). + +weighted_union_gen(Gen) -> + FreqChoices = get_prop(subenv, Gen), + proper_gen:weighted_union_gen(FreqChoices). + +%% @private +-spec safe_union([raw_type(),...]) -> proper_types:type(). +safe_union(RawChoices) -> + Choices = [cook_outer(C) || C <- RawChoices], + subtype( + [{subenv, Choices}, + {generator, {typed, fun safe_union_gen/1}}], + union(Choices)). + +safe_union_gen(Type) -> + Choices = get_prop(subenv, Type), + proper_gen:safe_union_gen(Choices). + +%% @private +-spec safe_weighted_union([{frequency(),raw_type()},...]) -> + proper_types:type(). +safe_weighted_union(RawFreqChoices) -> + CookFreqType = fun({Freq,RawType}) -> + {Freq,cook_outer(RawType)} end, + FreqChoices = lists:map(CookFreqType, RawFreqChoices), + Choices = [T || {_F,T} <- FreqChoices], + subtype([{subenv, FreqChoices}, + {generator, {typed, fun safe_weighted_union_gen/1}}], + union(Choices)). + +safe_weighted_union_gen(Type) -> + FreqChoices = get_prop(subenv, Type), + proper_gen:safe_weighted_union_gen(FreqChoices). + +%% @doc All tuples whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a tuple of types. +-spec tuple(ListOfTypes::[raw_type()]) -> proper_types:type(). +tuple(RawFields) -> + Fields = [cook_outer(F) || F <- RawFields], + ?CONTAINER([ + {env, Fields}, + {generator, {typed, fun tuple_gen/1}}, + {is_instance, {typed, fun tuple_is_instance/2}}, + {internal_types, list_to_tuple(Fields)}, + {get_indices, fun tuple_get_indices/2}, + {retrieve, fun erlang:element/2}, + {update, fun tuple_update/3} + ]). + +tuple_gen(Type) -> + Fields = get_prop(env, Type), + proper_gen:tuple_gen(Fields). + +tuple_is_instance(Type, X) -> + Fields = get_prop(env, Type), + is_tuple(X) andalso fixed_list_test(tuple_to_list(X), Fields). + +tuple_get_indices(Type, _X) -> + lists:seq(1, length(get_prop(env, Type))). + +-spec tuple_update(index(), value(), tuple()) -> tuple(). +tuple_update(Index, NewElem, Tuple) -> + setelement(Index, Tuple, NewElem). + +%% @doc Tuples whose elements are all of type `ElemType'. +%% Instances shrink towards the 0-size tuple, `{}'. +-spec loose_tuple(ElemType::raw_type()) -> proper_types:type(). +loose_tuple(RawElemType) -> + ElemType = cook_outer(RawElemType), + ?WRAPPER([ + {env, ElemType}, + {generator, {typed, fun loose_tuple_gen/2}}, + {reverse_gen, {typed, fun loose_tuple_rev/2}}, + {is_instance, {typed, fun loose_tuple_is_instance/2}} + ]). + +loose_tuple_gen(Type, Size) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_gen(Size, ElemType). + +loose_tuple_rev(Type, X) -> + ElemType = get_prop(env, Type), + proper_gen:loose_tuple_rev(X, ElemType). + +loose_tuple_is_instance(Type, X) -> + ElemType = get_prop(env, Type), + is_tuple(X) andalso list_test(tuple_to_list(X), ElemType). + +%% @doc Singleton type consisting only of `E'. `E' must be an evaluated term. +%% Also written simply as `E'. +-spec exactly(term()) -> proper_types:type(). +exactly(E) -> + ?BASIC([ + {env, E}, + {generator, {typed, fun exactly_gen/1}}, + {is_instance, {typed, fun exactly_is_instance/2}} + ]). + +exactly_gen(Type) -> + E = get_prop(env, Type), + proper_gen:exactly_gen(E). + +exactly_is_instance(Type, X) -> + E = get_prop(env, Type), + X =:= E. + +%% @doc All lists whose i-th element is an instance of the type at index i of +%% `ListOfTypes'. Also written simply as a list of types. +-spec fixed_list(ListOfTypes::maybe_improper_list(raw_type(),raw_type()|[])) -> + proper_types:type(). +fixed_list(MaybeImproperRawFields) -> + %% CAUTION: must handle improper lists + {Fields, Internal, Len, Retrieve, Update} = + case proper_arith:cut_improper_tail(MaybeImproperRawFields) of + % TODO: have cut_improper_tail return the length and use it in test? + {ProperRawHead, ImproperRawTail} -> + HeadLen = length(ProperRawHead), + CookedHead = [cook_outer(F) || F <- ProperRawHead], + CookedTail = cook_outer(ImproperRawTail), + {{CookedHead,CookedTail}, + CookedHead ++ CookedTail, + HeadLen + 1, + fun(I,L) -> improper_list_retrieve(I, L, HeadLen) end, + fun(I,V,L) -> improper_list_update(I, V, L, HeadLen) end}; + ProperRawFields -> + LocalFields = [cook_outer(F) || F <- ProperRawFields], + {LocalFields, + LocalFields, + length(ProperRawFields), + fun lists:nth/2, + fun proper_arith:list_update/3} + end, + ?CONTAINER([ + {env, {Fields, Len}}, + {generator, {typed, fun fixed_list_gen/1}}, + {is_instance, {typed, fun fixed_list_is_instance/2}}, + {internal_types, Internal}, + {get_indices, fun fixed_list_get_indices/2}, + {retrieve, Retrieve}, + {update, Update} + ]). + +fixed_list_gen(Type) -> + {Fields, _} = get_prop(env, Type), + proper_gen:fixed_list_gen(Fields). + +fixed_list_is_instance(Type, X) -> + {Fields, _} = get_prop(env, Type), + fixed_list_test(X, Fields). + +fixed_list_get_indices(Type, _X) -> + {_, Len} = get_prop(env, Type), + lists:seq(1, Len). + +-spec fixed_list_test(proper_gen:imm_instance(), + [proper_types:type()] | {[proper_types:type()], + proper_types:type()}) -> + boolean(). +fixed_list_test(X, {ProperHead,ImproperTail}) -> + is_list(X) andalso + begin + ProperHeadLen = length(ProperHead), + proper_arith:head_length(X) >= ProperHeadLen andalso + begin + {XHead,XTail} = lists:split(ProperHeadLen, X), + fixed_list_test(XHead, ProperHead) + andalso is_instance(XTail, ImproperTail) + end + end; +fixed_list_test(X, ProperFields) -> + is_list(X) + andalso length(X) =:= length(ProperFields) + andalso lists:all(fun({E,T}) -> is_instance(E, T) end, + lists:zip(X, ProperFields)). + +%% TODO: Move these 2 functions to proper_arith? +-spec improper_list_retrieve(index(), nonempty_improper_list(value(),value()), + pos_integer()) -> value(). +improper_list_retrieve(Index, List, HeadLen) -> + case Index =< HeadLen of + true -> lists:nth(Index, List); + false -> lists:nthtail(HeadLen, List) + end. + +-spec improper_list_update(index(), value(), + nonempty_improper_list(value(),value()), + pos_integer()) -> + nonempty_improper_list(value(),value()). +improper_list_update(Index, Value, List, HeadLen) -> + case Index =< HeadLen of + %% TODO: This happens to work, but is not implied by list_update's spec. + true -> proper_arith:list_update(Index, Value, List); + false -> lists:sublist(List, HeadLen) ++ Value + end. + +%% @doc All pure functions that map instances of `ArgTypes' to instances of +%% `RetType'. The syntax `function(Arity, RetType)' is also acceptable. +-spec function(ArgTypes::[raw_type()] | arity(), RetType::raw_type()) -> + proper_types:type(). +function(Arity, RawRetType) when is_integer(Arity), Arity >= 0, Arity =< 255 -> + RetType = cook_outer(RawRetType), + ?BASIC([ + {env, {Arity, RetType}}, + {generator, {typed, fun function_gen/1}}, + {is_instance, {typed, fun function_is_instance/2}} + ]); +function(RawArgTypes, RawRetType) -> + function(length(RawArgTypes), RawRetType). + +function_gen(Type) -> + {Arity, RetType} = get_prop(env, Type), + proper_gen:function_gen(Arity, RetType). + +function_is_instance(Type, X) -> + {Arity, RetType} = get_prop(env, Type), + is_function(X, Arity) + %% TODO: what if it's not a function we produced? + andalso equal_types(RetType, proper_gen:get_ret_type(X)). + +%% @doc All Erlang terms (that PropEr can produce). For reasons of efficiency, +%% functions are never produced as instances of this type.<br /> +%% CAUTION: Instances of this type are expensive to produce, shrink and instance- +%% check, both in terms of processing time and consumed memory. Only use this +%% type if you are certain that you need it. +-spec any() -> proper_types:type(). +any() -> + AllTypes = [integer(),float(),atom(),bitstring(),?LAZY(loose_tuple(any())), + ?LAZY(list(any()))], + ?SUBTYPE(union(AllTypes), [ + {generator, fun proper_gen:any_gen/1} + ]). + + +%%------------------------------------------------------------------------------ +%% Type aliases +%%------------------------------------------------------------------------------ + +%% @equiv integer(inf, inf) +-spec integer() -> proper_types:type(). +integer() -> integer(inf, inf). + +%% @equiv integer(0, inf) +-spec non_neg_integer() -> proper_types:type(). +non_neg_integer() -> integer(0, inf). + +%% @equiv integer(1, inf) +-spec pos_integer() -> proper_types:type(). +pos_integer() -> integer(1, inf). + +%% @equiv integer(inf, -1) +-spec neg_integer() -> proper_types:type(). +neg_integer() -> integer(inf, -1). + +%% @equiv integer(Low, High) +-spec range(extint(), extint()) -> proper_types:type(). +range(Low, High) -> integer(Low, High). + +%% @equiv float(inf, inf) +-spec float() -> proper_types:type(). +float() -> float(inf, inf). + +%% @equiv float(0.0, inf) +-spec non_neg_float() -> proper_types:type(). +non_neg_float() -> float(0.0, inf). + +%% @equiv union([integer(), float()]) +-spec number() -> proper_types:type(). +number() -> union([integer(), float()]). + +%% @doc The atoms `true' and `false'. Instances shrink towards `false'. +-spec boolean() -> proper_types:type(). +boolean() -> union(['false', 'true']). + +%% @equiv integer(0, 255) +-spec byte() -> proper_types:type(). +byte() -> integer(0, 255). + +%% @equiv integer(0, 16#10ffff) +-spec char() -> proper_types:type(). +char() -> integer(0, 16#10ffff). + +%% @equiv list(any()) +-spec list() -> proper_types:type(). +list() -> list(any()). + +%% @equiv loose_tuple(any()) +-spec tuple() -> proper_types:type(). +tuple() -> loose_tuple(any()). + +%% @equiv list(char()) +-spec string() -> proper_types:type(). +string() -> list(char()). + +%% @equiv weighted_union(FreqChoices) +-spec wunion([{frequency(),raw_type()},...]) -> proper_types:type(). +wunion(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv any() +-spec term() -> proper_types:type(). +term() -> any(). + +%% @equiv union([non_neg_integer() | infinity]) +-spec timeout() -> proper_types:type(). +timeout() -> union([non_neg_integer(), 'infinity']). + +%% @equiv integer(0, 255) +-spec arity() -> proper_types:type(). +arity() -> integer(0, 255). + + +%%------------------------------------------------------------------------------ +%% QuickCheck compatibility types +%%------------------------------------------------------------------------------ + +%% @doc Small integers (bound by the current value of the `size' parameter). +%% Instances shrink towards `0'. +-spec int() -> proper_types:type(). +int() -> ?SIZED(Size, integer(-Size,Size)). + +%% @doc Small non-negative integers (bound by the current value of the `size' +%% parameter). Instances shrink towards `0'. +-spec nat() -> proper_types:type(). +nat() -> ?SIZED(Size, integer(0,Size)). + +%% @equiv integer() +-spec largeint() -> proper_types:type(). +largeint() -> integer(). + +%% @equiv float() +-spec real() -> proper_types:type(). +real() -> float(). + +%% @equiv boolean() +-spec bool() -> proper_types:type(). +bool() -> boolean(). + +%% @equiv integer(Low, High) +-spec choose(extint(), extint()) -> proper_types:type(). +choose(Low, High) -> integer(Low, High). + +%% @equiv union(Choices) +-spec elements([raw_type(),...]) -> proper_types:type(). +elements(Choices) -> union(Choices). + +%% @equiv union(Choices) +-spec oneof([raw_type(),...]) -> proper_types:type(). +oneof(Choices) -> union(Choices). + +%% @equiv weighted_union(Choices) +-spec frequency([{frequency(),raw_type()},...]) -> proper_types:type(). +frequency(FreqChoices) -> weighted_union(FreqChoices). + +%% @equiv exactly(E) +-spec return(term()) -> proper_types:type(). +return(E) -> exactly(E). + +%% @doc Adds a default value, `Default', to `Type'. +%% The default serves as a primary shrinking target for instances, while it +%% is also chosen by the random instance generation subsystem half the time. +-spec default(raw_type(), raw_type()) -> proper_types:type(). +default(Default, Type) -> + union([Default, Type]). + +%% @doc All sorted lists containing elements of type `ElemType'. +%% Instances shrink towards the empty list, `[]'. +-spec orderedlist(ElemType::raw_type()) -> proper_types:type(). +orderedlist(RawElemType) -> + ?LET(L, list(RawElemType), lists:sort(L)). + +%% @equiv function(0, RetType) +-spec function0(raw_type()) -> proper_types:type(). +function0(RetType) -> + function(0, RetType). + +%% @equiv function(1, RetType) +-spec function1(raw_type()) -> proper_types:type(). +function1(RetType) -> + function(1, RetType). + +%% @equiv function(2, RetType) +-spec function2(raw_type()) -> proper_types:type(). +function2(RetType) -> + function(2, RetType). + +%% @equiv function(3, RetType) +-spec function3(raw_type()) -> proper_types:type(). +function3(RetType) -> + function(3, RetType). + +%% @equiv function(4, RetType) +-spec function4(raw_type()) -> proper_types:type(). +function4(RetType) -> + function(4, RetType). + +%% @doc A specialization of {@link default/2}, where `Default' and `Type' are +%% assigned weights to be considered by the random instance generator. The +%% shrinking subsystem will ignore the weights and try to shrink using the +%% default value. +-spec weighted_default({frequency(),raw_type()}, {frequency(),raw_type()}) -> + proper_types:type(). +weighted_default(Default, Type) -> + weighted_union([Default, Type]). + + +%%------------------------------------------------------------------------------ +%% Additional type specification functions +%%------------------------------------------------------------------------------ + +%% @doc Overrides the `size' parameter used when generating instances of +%% `Type' with `NewSize'. Has no effect on size-less types, such as unions. +%% Also, this will not affect the generation of any internal types contained in +%% `Type', such as the elements of a list - those will still be generated +%% using the test-wide value of `size'. One use of this function is to modify +%% types to produce instances that grow faster or slower, like so: +%% ```?SIZED(Size, resize(Size * 2, list(integer()))''' +%% The above specifies a list type that grows twice as fast as normal lists. +-spec resize(size(), Type::raw_type()) -> proper_types:type(). +resize(NewSize, RawType) -> + Type = cook_outer(RawType), + case find_prop(size_transform, Type) of + {ok,Transform} -> + add_prop(size_transform, fun(_S) -> Transform(NewSize) end, Type); + error -> + add_prop(size_transform, fun(_S) -> NewSize end, Type) + end. + +%% @doc This is a predefined constraint that can be applied to random-length +%% list and binary types to ensure that the produced values are never empty. +%% +%% e.g. {@link list/0}, {@link string/0}, {@link binary/0}) +-spec non_empty(ListType::raw_type()) -> proper_types:type(). +non_empty(RawListType) -> + ?SUCHTHAT(L, RawListType, L =/= [] andalso L =/= <<>>). + +%% @doc Creates a new type which is equivalent to `Type', but whose instances +%% are never shrunk by the shrinking subsystem. +-spec noshrink(Type::raw_type()) -> proper_types:type(). +noshrink(RawType) -> + add_prop(noshrink, true, cook_outer(RawType)). + +%% @doc Associates the atom key `Parameter' with the value `Value' while +%% generating instances of `Type'. +-spec with_parameter(atom(), value(), Type::raw_type()) -> proper_types:type(). +with_parameter(Parameter, Value, RawType) -> + with_parameters([{Parameter,Value}], RawType). + +%% @doc Similar to {@link with_parameter/3}, but accepts a list of +%% `{Parameter, Value}' pairs. +-spec with_parameters([{atom(),value()}], Type::raw_type()) -> + proper_types:type(). +with_parameters(PVlist, RawType) -> + Type = cook_outer(RawType), + case find_prop(parameters, Type) of + {ok,Params} when is_list(Params) -> + append_list_to_prop(parameters, PVlist, Type); + error -> + add_prop(parameters, PVlist, Type) + end. + +%% @doc Returns the value associated with `Parameter', or `Default' in case +%% `Parameter' is not associated with any value. +-spec parameter(atom(), value()) -> value(). +parameter(Parameter, Default) -> + Parameters = + case erlang:get('$parameters') of + undefined -> []; + List -> List + end, + proplists:get_value(Parameter, Parameters, Default). + +%% @equiv parameter(Parameter, undefined) +-spec parameter(atom()) -> value(). +parameter(Parameter) -> + parameter(Parameter, undefined). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl new file mode 100644 index 0000000000..b6cab5e24b --- /dev/null +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl @@ -0,0 +1,2401 @@ +%%% Copyright 2010-2015 Manolis Papadakis <[email protected]>, +%%% Eirini Arvaniti <[email protected]> +%%% and Kostis Sagonas <[email protected]> +%%% +%%% This file is part of PropEr. +%%% +%%% PropEr is free software: you can redistribute it and/or modify +%%% it under the terms of the GNU General Public License as published by +%%% the Free Software Foundation, either version 3 of the License, or +%%% (at your option) any later version. +%%% +%%% PropEr is distributed in the hope that it will be useful, +%%% but WITHOUT ANY WARRANTY; without even the implied warranty of +%%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +%%% GNU General Public License for more details. +%%% +%%% You should have received a copy of the GNU General Public License +%%% along with PropEr. If not, see <http://www.gnu.org/licenses/>. + +%%% @copyright 2010-2015 Manolis Papadakis, Eirini Arvaniti and Kostis Sagonas +%%% @version {@version} +%%% @author Manolis Papadakis + +%%% @doc Erlang type system - PropEr type system integration module. +%%% +%%% PropEr can parse types expressed in Erlang's type language and convert them +%%% to its own type format. Such expressions can be used instead of regular type +%%% constructors in the second argument of `?FORALL's. No extra notation is +%%% required; PropEr will detect which calls correspond to native types by +%%% applying a parse transform during compilation. This parse transform is +%%% automatically applied to any module that includes the `proper.hrl' header +%%% file. You can disable this feature by compiling your modules with +%%% `-DPROPER_NO_TRANS'. Note that this will currently also disable the +%%% automatic exporting of properties. +%%% +%%% The use of native types in properties is subject to the following usage +%%% rules: +%%% <ul> +%%% <li>Native types cannot be used outside of `?FORALL's.</li> +%%% <li>Inside `?FORALL's, native types can be combined with other native +%%% types, and even with PropEr types, inside tuples and lists (the constructs +%%% `[...]', `{...}' and `++' are all allowed).</li> +%%% <li>All other constructs of Erlang's built-in type system (e.g. `|' for +%%% union, `_' as an alias of `any()', `<<_:_>>' binary type syntax and +%%% `fun((...) -> ...)' function type syntax) are not allowed in `?FORALL's, +%%% because they are rejected by the Erlang parser.</li> +%%% <li>Anything other than a tuple constructor, list constructor, `++' +%%% application, local or remote call will automatically be considered a +%%% PropEr type constructor and not be processed further by the parse +%%% transform.</li> +%%% <li>Parametric native types are fully supported; of course, they can only +%%% appear instantiated in a `?FORALL'. The arguments of parametric native +%%% types are always interpreted as native types.</li> +%%% <li>Parametric PropEr types, on the other hand, can take any kind of +%%% argument. You can even mix native and PropEr types in the arguments of a +%%% PropEr type. For example, assuming that the following declarations are +%%% present: +%%% ``` my_proper_type() -> ?LET(...). +%%% -type my_native_type() :: ... .''' +%%% Then the following expressions are all legal: +%%% ``` vector(2, my_native_type()) +%%% function(0, my_native_type()) +%%% union([my_proper_type(), my_native_type()])''' </li> +%%% <li>Some type constructors can take native types as arguments (but only +%%% inside `?FORALL's): +%%% <ul> +%%% <li>`?SUCHTHAT', `?SUCHTHATMAYBE', `non_empty', `noshrink': these work +%%% with native types too</li> +%%% <li>`?LAZY', `?SHRINK', `resize', `?SIZED': these don't work with native +%%% types</li> +%%% <li>`?LET', `?LETSHRINK': only the top-level base type can be a native +%%% type</li> +%%% </ul></li> +%%% <li>Native type declarations in the `?FORALL's of a module can reference any +%%% custom type declared in a `-type' or `-opaque' attribute of the same +%%% module, as long as no module identifier is used.</li> +%%% <li>Typed records cannot be referenced inside `?FORALL's using the +%%% `#rec_name{}' syntax. To use a typed record in a `?FORALL', enclose the +%%% record in a custom type like so: +%%% ``` -type rec_name() :: #rec_name{}. ''' +%%% and use the custom type instead.</li> +%%% <li>`?FORALL's may contain references to self-recursive or mutually +%%% recursive native types, so long as each type in the hierarchy has a clear +%%% base case. +%%% Currently, PropEr requires that the toplevel of any recursive type +%%% declaration is either a (maybe empty) list or a union containing at least +%%% one choice that doesn't reference the type directly (it may, however, +%%% reference any of the types that are mutually recursive with it). This +%%% means, for example, that some valid recursive type declarations, such as +%%% this one: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none' | a()}. ''' +%%% are not accepted by PropEr. However, such types can be rewritten in a way +%%% that allows PropEr to parse them: +%%% ``` ?FORALL(..., a(), ...) ''' +%%% where: +%%% ``` -type a() :: {'a','none'} | {'a',a()}. ''' +%%% This also means that recursive record declarations are not allowed: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% A little rewritting can usually remedy this problem as well: +%%% ``` ?FORALL(..., rec(), ...) ''' +%%% where: +%%% ``` -type rec() :: #rec{b :: 'nil'} | #rec{b :: rec()}. +%%% -record(rec, {a = 0 :: integer(), b = 'nil' :: 'nil' | #rec{}}). ''' +%%% </li> +%%% <li>Remote types may be referenced in a `?FORALL', so long as they are +%%% exported from the remote module. Currently, PropEr requires that any +%%% remote modules whose types are directly referenced from within properties +%%% are present in the code path at compile time, either compiled with +%%% `debug_info' enabled or in source form. If PropEr cannot find a remote +%%% module at all, finds only a compiled object file with no debug +%%% information or fails to compile the source file, all calls to that module +%%% will automatically be considered calls to PropEr type constructors.</li> +%%% <li>For native types to be translated correctly, both the module that +%%% contains the `?FORALL' declaration as well as any module that contains +%%% the declaration of a type referenced (directly or indirectly) from inside +%%% a `?FORALL' must be present in the code path at runtime, either compiled +%%% with `debug_info' enabled or in source form.</li> +%%% <li>Local types with the same name as an auto-imported BIF are not accepted +%%% by PropEr, unless the BIF in question has been declared in a +%%% `no_auto_import' option.</li> +%%% <li>When an expression can be interpreted both as a PropEr type and as a +%%% native type, the former takes precedence. This means that a function +%%% `foo()' will shadow a type `foo()' if they are both present in the module. +%%% The same rule applies to remote functions and types as well.</li> +%%% <li>The above may cause some confusion when list syntax is used: +%%% <ul> +%%% <li>The expression `[integer()]' can be interpreted both ways, so the +%%% PropEr way applies. Therefore, instances of this type will always be +%%% lists of length 1, not arbitrary integer lists, as would be expected +%%% when interpreting the expression as a native type.</li> +%%% <li>Assuming that a custom type foo/1 has been declared, the expression +%%% `foo([integer()])' can only be interpreted as a native type declaration, +%%% which means that the generic type of integer lists will be passed to +%%% `foo/1'.</li> +%%% </ul></li> +%%% <li>Currently, PropEr does not detect the following mistakes: +%%% <ul> +%%% <li>inline record-field specializations that reference non-existent +%%% fields</li> +%%% <li>type parameters that are not present in the RHS of a `-type' +%%% declaration</li> +%%% <li>using `_' as a type variable in the LHS of a `-type' declaration</li> +%%% <li>using the same variable in more than one position in the LHS of a +%%% `-type' declaration</li> +%%% </ul> +%%% </li> +%%% </ul> +%%% +%%% You can use <a href="#index">these</a> functions to try out the type +%%% translation subsystem. +%%% +%%% CAUTION: These functions should never be used inside properties. They are +%%% meant for demonstration purposes only. + +-module(proper_typeserver). +-behaviour(gen_server). +-export([demo_translate_type/2, demo_is_instance/3]). + +-export([start/0, restart/0, stop/0, create_spec_test/3, get_exp_specced/1, + is_instance/3, translate_type/1]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, + code_change/3]). +-export([get_exp_info/1, match/2]). + +-export_type([imm_type/0, mod_exp_types/0, mod_exp_funs/0]). + +-include("proper_internal.hrl"). + + +%%------------------------------------------------------------------------------ +%% Macros +%%------------------------------------------------------------------------------ + +-define(SRC_FILE_EXT, ".erl"). + +%% CAUTION: all these must be sorted +-define(STD_TYPES_0, + [any,arity,atom,binary,bitstring,bool,boolean,byte,char,float,integer, + list,neg_integer,non_neg_integer,number,pos_integer,string,term, + timeout]). +-define(HARD_ADTS, + %% gb_trees:iterator and gb_sets:iterator are NOT hardcoded + [{{array,0},array}, {{array,1},proper_array}, + {{dict,0},dict}, {{dict,2},proper_dict}, + {{gb_set,0},gb_sets}, {{gb_set,1},proper_gb_sets}, + {{gb_tree,0},gb_trees}, {{gb_tree,2},proper_gb_trees}, + {{orddict,2},proper_orddict}, + {{ordset,1},proper_ordsets}, + {{queue,0},queue}, {{queue,1},proper_queue}, + {{set,0},sets}, {{set,1},proper_sets}]). +-define(HARD_ADT_MODS, + [{array, [{{array,0}, + {{type,0,record,[{atom,0,array}]},[]}}]}, + {dict, [{{dict,0}, + {{type,0,record,[{atom,0,dict}]},[]}}]}, + {gb_sets, [{{gb_set,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_set_node,[]}]},[]}}]}, + {gb_trees, [{{gb_tree,0}, + {{type,0,tuple,[{type,0,non_neg_integer,[]}, + {type,0,gb_tree_node,[]}]},[]}}]}, + %% Our parametric ADTs are already declared as normal types, we just + %% need to change them to opaques. + {proper_array, [{{array,1},already_declared}]}, + {proper_dict, [{{dict,2},already_declared}]}, + {proper_gb_sets, [{{gb_set,1},already_declared}, + {{iterator,1},already_declared}]}, + {proper_gb_trees, [{{gb_tree,2},already_declared}, + {{iterator,2},already_declared}]}, + {proper_orddict, [{{orddict,2},already_declared}]}, + {proper_ordsets, [{{ordset,1},already_declared}]}, + {proper_queue, [{{queue,1},already_declared}]}, + {proper_sets, [{{set,1},already_declared}]}, + {queue, [{{queue,0}, + {{type,0,tuple,[{type,0,list,[]},{type,0,list,[]}]},[]}}]}, + {sets, [{{set,0}, + {{type,0,record,[{atom,0,set}]},[]}}]}]). + + +%%------------------------------------------------------------------------------ +%% Types +%%------------------------------------------------------------------------------ + +-type type_name() :: atom(). +-type var_name() :: atom(). %% TODO: also integers? +-type field_name() :: atom(). + +-type type_kind() :: 'type' | 'record'. +-type type_ref() :: {type_kind(),type_name(),arity()}. +-ifdef(NO_MODULES_IN_OPAQUES). +-type substs_dict() :: dict(). %% dict(field_name(),ret_type()) +-else. +-type substs_dict() :: dict:dict(field_name(),ret_type()). +-endif. +-type full_type_ref() :: {mod_name(),type_kind(),type_name(), + [ret_type()] | substs_dict()}. +-type symb_info() :: 'not_symb' | {'orig_abs',abs_type()}. +-type type_repr() :: {'abs_type',abs_type(),[var_name()],symb_info()} + | {'cached',fin_type(),abs_type(),symb_info()} + | {'abs_record',[{field_name(),abs_type()}]}. +-type gen_fun() :: fun((size()) -> fin_type()). +-type rec_fun() :: fun(([gen_fun()],size()) -> fin_type()). +-type rec_arg() :: {boolean() | {'list',boolean(),rec_fun()},full_type_ref()}. +-type rec_args() :: [rec_arg()]. +-type ret_type() :: {'simple',fin_type()} | {'rec',rec_fun(),rec_args()}. +-type rec_fun_info() :: {pos_integer(),pos_integer(),[arity(),...], + [rec_fun(),...]}. + +-type imm_type_ref() :: {type_name(),arity()}. +-type hard_adt_repr() :: {abs_type(),[var_name()]} | 'already_declared'. +-type fun_ref() :: {fun_name(),arity()}. +-type fun_repr() :: fun_clause_repr(). +-type fun_clause_repr() :: {[abs_type()],abs_type()}. +-type proc_fun_ref() :: {fun_name(),[abs_type()],abs_type()}. +-type full_imm_type_ref() :: {mod_name(),type_name(),arity()}. +-type imm_stack() :: [full_imm_type_ref()]. +-type pat_field() :: 0 | 1 | atom(). +-type pattern() :: loose_tuple(pat_field()). +-type next_step() :: 'none' | 'take_head' | {'match_with',pattern()}. + +-ifdef(NO_MODULES_IN_OPAQUES). +%% @private_type +-type mod_exp_types() :: set(). %% set(imm_type_ref()) +-type mod_types() :: dict(). %% dict(type_ref(),type_repr()) +%% @private_type +-type mod_exp_funs() :: set(). %% set(fun_ref()) +-type mod_specs() :: dict(). %% dict(fun_ref(),fun_repr()) +-else. +%% @private_type +-type mod_exp_types() :: sets:set(imm_type_ref()). +-type mod_types() :: dict:dict(type_ref(),type_repr()). +%% @private_type +-type mod_exp_funs() :: sets:set(fun_ref()). +-type mod_specs() :: dict:dict(fun_ref(),fun_repr()). +-endif. + +-ifdef(NO_MODULES_IN_OPAQUES). +-record(state, + {cached = dict:new() :: dict(), %% dict(imm_type(),fin_type()) + exp_types = dict:new() :: dict(), %% dict(mod_name(),mod_exp_types()) + types = dict:new() :: dict(), %% dict(mod_name(),mod_types()) + exp_specs = dict:new() :: dict()}). %% dict(mod_name(),mod_specs()) +-else. +-record(state, + {cached = dict:new() :: dict:dict(), %% dict(imm_type(),fin_type()) + exp_types = dict:new() :: dict:dict(), %% dict(mod_name(),mod_exp_types()) + types = dict:new() :: dict:dict(), %% dict(mod_name(),mod_types()) + exp_specs = dict:new() :: dict:dict()}). %% dict(mod_name(),mod_specs()) +%% {cached = dict:new() :: dict:dict(imm_type(),fin_type()), +%% exp_types = dict:new() :: dict:dict(mod_name(),mod_exp_types()), +%% types = dict:new() :: dict:dict(mod_name(),mod_types()), +%% exp_specs = dict:new() :: dict:dict(mod_name(),mod_specs())}). +-endif. +-type state() :: #state{}. + +-record(mod_info, + {mod_exp_types = sets:new() :: mod_exp_types(), + mod_types = dict:new() :: mod_types(), + mod_opaques = sets:new() :: mod_exp_types(), + mod_exp_funs = sets:new() :: mod_exp_funs(), + mod_specs = dict:new() :: mod_specs()}). +-type mod_info() :: #mod_info{}. + +-type stack() :: [full_type_ref() | 'tuple' | 'list' | 'union' | 'fun']. +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_dict() :: dict(). %% dict(var_name(),ret_type()) +-else. +-type var_dict() :: dict:dict(var_name(),ret_type()). +-endif. +%% @private_type +-type imm_type() :: {mod_name(),string()}. +%% @alias +-type fin_type() :: proper_types:type(). +-type tagged_result(T) :: {'ok',T} | 'error'. +-type tagged_result2(T,S) :: {'ok',T,S} | 'error'. +%% @alias +-type rich_result(T) :: {'ok',T} | {'error',term()}. +-type rich_result2(T,S) :: {'ok',T,S} | {'error',term()}. +-type false_positive_mfas() :: proper:false_positive_mfas(). + +-type server_call() :: {'create_spec_test',mfa(),timeout(),false_positive_mfas()} + | {'get_exp_specced',mod_name()} + | {'get_type_repr',mod_name(),type_ref(),boolean()} + | {'translate_type',imm_type()}. +-type server_response() :: rich_result(proper:test()) + | rich_result([mfa()]) + | rich_result(type_repr()) + | rich_result(fin_type()). + + +%%------------------------------------------------------------------------------ +%% Server interface functions +%%------------------------------------------------------------------------------ + +%% @private +-spec start() -> 'ok'. +start() -> + {ok,TypeserverPid} = gen_server:start_link(?MODULE, dummy, []), + put('$typeserver_pid', TypeserverPid), + ok. + +%% @private +-spec restart() -> 'ok'. +restart() -> + TypeserverPid = get('$typeserver_pid'), + case (TypeserverPid =:= undefined orelse not is_process_alive(TypeserverPid)) of + true -> start(); + false -> ok + end. + +%% @private +-spec stop() -> 'ok'. +stop() -> + TypeserverPid = get('$typeserver_pid'), + erase('$typeserver_pid'), + gen_server:cast(TypeserverPid, stop). + +%% @private +-spec create_spec_test(mfa(), timeout(), false_positive_mfas()) -> rich_result(proper:test()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}). + +%% @private +-spec get_exp_specced(mod_name()) -> rich_result([mfa()]). +get_exp_specced(Mod) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_exp_specced,Mod}). + +-spec get_type_repr(mod_name(), type_ref(), boolean()) -> + rich_result(type_repr()). +get_type_repr(Mod, TypeRef, IsRemote) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {get_type_repr,Mod,TypeRef,IsRemote}). + +%% @private +-spec translate_type(imm_type()) -> rich_result(fin_type()). +translate_type(ImmType) -> + TypeserverPid = get('$typeserver_pid'), + gen_server:call(TypeserverPid, {translate_type,ImmType}). + +%% @doc Translates the native type expression `TypeExpr' (which should be +%% provided inside a string) into a PropEr type, which can then be passed to any +%% of the demo functions defined in the {@link proper_gen} module. PropEr acts +%% as if it found this type expression inside the code of module `Mod'. +-spec demo_translate_type(mod_name(), string()) -> rich_result(fin_type()). +demo_translate_type(Mod, TypeExpr) -> + start(), + Result = translate_type({Mod,TypeExpr}), + stop(), + Result. + +%% @doc Checks if `Term' is a valid instance of native type `TypeExpr' (which +%% should be provided inside a string). PropEr acts as if it found this type +%% expression inside the code of module `Mod'. +-spec demo_is_instance(term(), mod_name(), string()) -> + boolean() | {'error',term()}. +demo_is_instance(Term, Mod, TypeExpr) -> + case parse_type(TypeExpr) of + {ok,TypeForm} -> + start(), + Result = + %% Force the typeserver to load the module. + case translate_type({Mod,"integer()"}) of + {ok,_FinType} -> + try is_instance(Term, Mod, TypeForm) + catch + throw:{'$typeserver',Reason} -> {error, Reason} + end; + {error,_Reason} = Error -> + Error + end, + stop(), + Result; + {error,_Reason} = Error -> + Error + end. + + +%%------------------------------------------------------------------------------ +%% Implementation of gen_server interface +%%------------------------------------------------------------------------------ + +%% @private +-spec init(_) -> {'ok',state()}. +init(_) -> + {ok, #state{}}. + +%% @private +-spec handle_call(server_call(), _, state()) -> + {'reply',server_response(),state()}. +handle_call({create_spec_test,MFA,SpecTimeout,FalsePositiveMFAs}, _From, State) -> + case create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) of + {ok,Test,NewState} -> + {reply, {ok,Test}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_exp_specced,Mod}, _From, State) -> + case get_exp_specced(Mod, State) of + {ok,MFAs,NewState} -> + {reply, {ok,MFAs}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({get_type_repr,Mod,TypeRef,IsRemote}, _From, State) -> + case get_type_repr(Mod, TypeRef, IsRemote, State) of + {ok,TypeRepr,NewState} -> + {reply, {ok,TypeRepr}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end; +handle_call({translate_type,ImmType}, _From, State) -> + case translate_type(ImmType, State) of + {ok,FinType,NewState} -> + {reply, {ok,FinType}, NewState}; + {error,_Reason} = Error -> + {reply, Error, State} + end. + +%% @private +-spec handle_cast('stop', state()) -> {'stop','normal',state()}. +handle_cast(stop, State) -> + {stop, normal, State}. + +%% @private +-spec handle_info(term(), state()) -> {'stop',{'received_info',term()},state()}. +handle_info(Info, State) -> + {stop, {received_info,Info}, State}. + +%% @private +-spec terminate(term(), state()) -> 'ok'. +terminate(_Reason, _State) -> + ok. + +%% @private +-spec code_change(term(), state(), _) -> {'ok',state()}. +code_change(_OldVsn, State, _) -> + {ok, State}. + + +%%------------------------------------------------------------------------------ +%% Top-level interface +%%------------------------------------------------------------------------------ + +-spec create_spec_test(mfa(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +create_spec_test(MFA, SpecTimeout, FalsePositiveMFAs, State) -> + case get_exp_spec(MFA, State) of + {ok,FunRepr,NewState} -> + make_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, NewState); + {error,_Reason} = Error -> + Error + end. + +-spec get_exp_spec(mfa(), state()) -> rich_result2(fun_repr(),state()). +get_exp_spec({Mod,Fun,Arity} = MFA, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + case dict:find({Fun,Arity}, ModExpSpecs) of + {ok,FunRepr} -> + {ok, FunRepr, NewState}; + error -> + {error, {function_not_exported_or_specced,MFA}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec make_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), state()) -> + rich_result2(proper:test(),state()). +make_spec_test({Mod,_Fun,_Arity}=MFA, {Domain,_Range}=FunRepr, SpecTimeout, FalsePositiveMFAs, State) -> + case convert(Mod, {type,0,'$fixed_list',Domain}, State) of + {ok,FinType,NewState} -> + Test = ?FORALL(Args, FinType, apply_spec_test(MFA, FunRepr, SpecTimeout, FalsePositiveMFAs, Args)), + {ok, Test, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec apply_spec_test(mfa(), fun_repr(), timeout(), false_positive_mfas(), term()) -> proper:test(). +apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiveMFAs, Args) -> + ?TIMEOUT(SpecTimeout, + begin + %% NOTE: only call apply/3 inside try/catch (do not trust ?MODULE:is_instance/3) + Result = + try apply(Mod,Fun,Args) of + X -> {ok, X} + catch + X:Y -> {X, Y} + end, + case Result of + {ok, Z} -> + case ?MODULE:is_instance(Z,Mod,Range) of + true -> + true; + false when is_function(FalsePositiveMFAs) -> + FalsePositiveMFAs(MFA, Args, {fail, Z}); + false -> + false + end; + Exception when is_function(FalsePositiveMFAs) -> + case FalsePositiveMFAs(MFA, Args, Exception) of + true -> + true; + false -> + error(Exception, erlang:get_stacktrace()) + end; + Exception -> + error(Exception, erlang:get_stacktrace()) + end + end). + +-spec get_exp_specced(mod_name(), state()) -> rich_result2([mfa()],state()). +get_exp_specced(Mod, State) -> + case add_module(Mod, State) of + {ok,#state{exp_specs = ExpSpecs} = NewState} -> + ModExpSpecs = dict:fetch(Mod, ExpSpecs), + ExpSpecced = [{Mod,F,A} || {F,A} <- dict:fetch_keys(ModExpSpecs)], + {ok, ExpSpecced, NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec get_type_repr(mod_name(), type_ref(), boolean(), state()) -> + rich_result2(type_repr(),state()). +get_type_repr(Mod, {type,Name,Arity} = TypeRef, true, State) -> + case prepare_for_remote(Mod, Name, Arity, State) of + {ok,NewState} -> + get_type_repr(Mod, TypeRef, false, NewState); + {error,_Reason} = Error -> + Error + end; +get_type_repr(Mod, TypeRef, false, #state{types = Types} = State) -> + ModTypes = dict:fetch(Mod, Types), + case dict:find(TypeRef, ModTypes) of + {ok,TypeRepr} -> + {ok, TypeRepr, State}; + error -> + {error, {missing_type,Mod,TypeRef}} + end. + +-spec prepare_for_remote(mod_name(), type_name(), arity(), state()) -> + rich_result(state()). +prepare_for_remote(RemMod, Name, Arity, State) -> + case add_module(RemMod, State) of + {ok,#state{exp_types = ExpTypes} = NewState} -> + RemModExpTypes = dict:fetch(RemMod, ExpTypes), + case sets:is_element({Name,Arity}, RemModExpTypes) of + true -> {ok, NewState}; + false -> {error, {type_not_exported,{RemMod,Name,Arity}}} + end; + {error,_Reason} = Error -> + Error + end. + +-spec translate_type(imm_type(), state()) -> rich_result2(fin_type(),state()). +translate_type({Mod,Str} = ImmType, #state{cached = Cached} = State) -> + case dict:find(ImmType, Cached) of + {ok,Type} -> + {ok, Type, State}; + error -> + case parse_type(Str) of + {ok,TypeForm} -> + case add_module(Mod, State) of + {ok,NewState} -> + case convert(Mod, TypeForm, NewState) of + {ok,FinType, + #state{cached = Cached} = FinalState} -> + NewCached = dict:store(ImmType, FinType, + Cached), + {ok, FinType, + FinalState#state{cached = NewCached}}; + {error,_Reason} = Error -> + Error + end; + {error,_Reason} = Error -> + Error + end; + {error,Reason} -> + {error, {parse_error,Str,Reason}} + end + end. + +-spec parse_type(string()) -> rich_result(abs_type()). +parse_type(Str) -> + TypeStr = "-type mytype() :: " ++ Str ++ ".", + case erl_scan:string(TypeStr) of + {ok,Tokens,_EndLocation} -> + case erl_parse:parse_form(Tokens) of + {ok,{attribute,_Line,type,{mytype,TypeExpr,[]}}} -> + {ok, TypeExpr}; + {error,_ErrorInfo} = Error -> + Error + end; + {error,ErrorInfo,_EndLocation} -> + {error, ErrorInfo} + end. + +-spec add_module(mod_name(), state()) -> rich_result(state()). +add_module(Mod, #state{exp_types = ExpTypes} = State) -> + case dict:is_key(Mod, ExpTypes) of + true -> + {ok, State}; + false -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + ModInfo = process_adts(Mod, RawModInfo), + {ok, store_mod_info(Mod,ModInfo,State)}; + {error,Reason} -> + {error, {cant_load_code,Mod,Reason}} + end + end. + +%% @private +-spec get_exp_info(mod_name()) -> rich_result2(mod_exp_types(),mod_exp_funs()). +get_exp_info(Mod) -> + case get_code_and_exports(Mod) of + {ok,AbsCode,ModExpFuns} -> + RawModInfo = get_mod_info(Mod, AbsCode, ModExpFuns), + {ok, RawModInfo#mod_info.mod_exp_types, ModExpFuns}; + {error,_Reason} = Error -> + Error + end. + +-spec get_code_and_exports(mod_name()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports(Mod) -> + case code:get_object_code(Mod) of + {Mod, ObjBin, _ObjFileName} -> + case get_chunks(ObjBin) of + {ok,_AbsCode,_ModExpFuns} = Result -> + Result; + {error,Reason} -> + get_code_and_exports_from_source(Mod, Reason) + end; + error -> + get_code_and_exports_from_source(Mod, cant_find_object_file) + end. + +-spec get_code_and_exports_from_source(mod_name(), term()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_code_and_exports_from_source(Mod, ObjError) -> + SrcFileName = atom_to_list(Mod) ++ ?SRC_FILE_EXT, + case code:where_is_file(SrcFileName) of + FullSrcFileName when is_list(FullSrcFileName) -> + Opts = [binary,debug_info,return_errors,{d,'PROPER_REMOVE_PROPS'}], + case compile:file(FullSrcFileName, Opts) of + {ok,Mod,Binary} -> + get_chunks(Binary); + {error,Errors,_Warnings} -> + {error, {ObjError,{cant_compile_source_file,Errors}}} + end; + non_existing -> + {error, {ObjError,cant_find_source_file}} + end. + +-spec get_chunks(string() | binary()) -> + rich_result2([abs_form()],mod_exp_funs()). +get_chunks(ObjFile) -> + case beam_lib:chunks(ObjFile, [abstract_code,exports]) of + {ok,{_Mod,[{abstract_code,AbsCodeChunk},{exports,ExpFunsList}]}} -> + case AbsCodeChunk of + {raw_abstract_v1,AbsCode} -> + %% HACK: Add a declaration for iolist() to every module + {ok, add_iolist(AbsCode), sets:from_list(ExpFunsList)}; + no_abstract_code -> + {error, no_abstract_code}; + _ -> + {error, unsupported_abstract_code_format} + end; + {error,beam_lib,Reason} -> + {error, Reason} + end. + +-spec add_iolist([abs_form()]) -> [abs_form()]. +add_iolist(Forms) -> + IOListDef = + {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}, + IOListDecl = {attribute,0,type,{iolist,IOListDef,[]}}, + [IOListDecl | Forms]. + +-spec get_mod_info(mod_name(), [abs_form()], mod_exp_funs()) -> mod_info(). +get_mod_info(Mod, AbsCode, ModExpFuns) -> + StartModInfo = #mod_info{mod_exp_funs = ModExpFuns}, + ImmModInfo = lists:foldl(fun add_mod_info/2, StartModInfo, AbsCode), + #mod_info{mod_specs = AllModSpecs} = ImmModInfo, + IsExported = fun(FunRef,_FunRepr) -> sets:is_element(FunRef,ModExpFuns) end, + ModExpSpecs = dict:filter(IsExported, AllModSpecs), + ModInfo = ImmModInfo#mod_info{mod_specs = ModExpSpecs}, + case orddict:find(Mod, ?HARD_ADT_MODS) of + {ok,ModADTs} -> + #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo, + ModADTsSet = + sets:from_list([ImmTypeRef + || {ImmTypeRef,_HardADTRepr} <- ModADTs]), + NewModExpTypes = sets:union(ModExpTypes, ModADTsSet), + NewModTypes = lists:foldl(fun store_hard_adt/2, ModTypes, ModADTs), + NewModOpaques = sets:union(ModOpaques, ModADTsSet), + ModInfo#mod_info{mod_exp_types = NewModExpTypes, + mod_types = NewModTypes, + mod_opaques = NewModOpaques}; + error -> + ModInfo + end. + +-spec store_hard_adt({imm_type_ref(),hard_adt_repr()}, mod_types()) -> + mod_types(). +store_hard_adt({_ImmTypeRef,already_declared}, ModTypes) -> + ModTypes; +store_hard_adt({{Name,Arity},{TypeForm,VarNames}}, ModTypes) -> + TypeRef = {type,Name,Arity}, + TypeRepr = {abs_type,TypeForm,VarNames,not_symb}, + dict:store(TypeRef, TypeRepr, ModTypes). + +-spec add_mod_info(abs_form(), mod_info()) -> mod_info(). +add_mod_info({attribute,_Line,export_type,TypesList}, + #mod_info{mod_exp_types = ModExpTypes} = ModInfo) -> + NewModExpTypes = sets:union(sets:from_list(TypesList), ModExpTypes), + ModInfo#mod_info{mod_exp_types = NewModExpTypes}; +add_mod_info({attribute,_Line,type,{{record,RecName},Fields,[]}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + FieldInfo = [process_rec_field(F) || F <- Fields], + NewModTypes = dict:store({record,RecName,0}, {abs_record,FieldInfo}, + ModTypes), + ModInfo#mod_info{mod_types = NewModTypes}; +add_mod_info({attribute,_Line,record,{RecName,Fields}}, + #mod_info{mod_types = ModTypes} = ModInfo) -> + case dict:is_key(RecName, ModTypes) of + true -> + ModInfo; + false -> + TypedRecord = {attribute,0,type,{{record,RecName},Fields,[]}}, + add_mod_info(TypedRecord, ModInfo) + end; +add_mod_info({attribute,_Line,Kind,{Name,TypeForm,VarForms}}, + #mod_info{mod_types = ModTypes, + mod_opaques = ModOpaques} = ModInfo) + when Kind =:= type; Kind =:= opaque -> + Arity = length(VarForms), + VarNames = [V || {var,_,V} <- VarForms], + %% TODO: No check whether variables are different, or non-'_'. + NewModTypes = dict:store({type,Name,Arity}, + {abs_type,TypeForm,VarNames,not_symb}, ModTypes), + NewModOpaques = + case Kind of + type -> ModOpaques; + opaque -> sets:add_element({Name,Arity}, ModOpaques) + end, + ModInfo#mod_info{mod_types = NewModTypes, mod_opaques = NewModOpaques}; +add_mod_info({attribute,_Line,spec,{RawFunRef,[RawFirstClause | _Rest]}}, + #mod_info{mod_specs = ModSpecs} = ModInfo) -> + FunRef = case RawFunRef of + {_Mod,Name,Arity} -> {Name,Arity}; + {_Name,_Arity} = F -> F + end, + %% TODO: We just take the first function clause. + FirstClause = process_fun_clause(RawFirstClause), + NewModSpecs = dict:store(FunRef, FirstClause, ModSpecs), + ModInfo#mod_info{mod_specs = NewModSpecs}; +add_mod_info(_Form, ModInfo) -> + ModInfo. + +-spec process_rec_field(abs_rec_field()) -> {field_name(),abs_type()}. +process_rec_field({record_field,_,{atom,_,FieldName}}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({record_field,_,{atom,_,FieldName},_Initialization}) -> + {FieldName, {type,0,any,[]}}; +process_rec_field({typed_record_field,RecField,FieldType}) -> + {FieldName,_} = process_rec_field(RecField), + {FieldName, FieldType}. + +-spec process_fun_clause(abs_type()) -> fun_clause_repr(). +process_fun_clause({type,_,'fun',[{type,_,product,Domain},Range]}) -> + {Domain, Range}; +process_fun_clause({type,_,bounded_fun,[MainClause,Constraints]}) -> + {RawDomain,RawRange} = process_fun_clause(MainClause), + VarSubsts = [{V,T} || {type,_,constraint, + [{atom,_,is_subtype},[{var,_,V},T]]} <- Constraints, + V =/= '_'], + VarSubstsDict = dict:from_list(VarSubsts), + Domain = [update_vars(A, VarSubstsDict, false) || A <- RawDomain], + Range = update_vars(RawRange, VarSubstsDict, false), + {Domain, Range}. + +-spec store_mod_info(mod_name(), mod_info(), state()) -> state(). +store_mod_info(Mod, #mod_info{mod_exp_types = ModExpTypes, mod_types = ModTypes, + mod_specs = ImmModExpSpecs}, + #state{exp_types = ExpTypes, types = Types, + exp_specs = ExpSpecs} = State) -> + NewExpTypes = dict:store(Mod, ModExpTypes, ExpTypes), + NewTypes = dict:store(Mod, ModTypes, Types), + ModExpSpecs = dict:map(fun unbound_to_any/2, ImmModExpSpecs), + NewExpSpecs = dict:store(Mod, ModExpSpecs, ExpSpecs), + State#state{exp_types = NewExpTypes, types = NewTypes, + exp_specs = NewExpSpecs}. + +-spec unbound_to_any(fun_ref(), fun_repr()) -> fun_repr(). +unbound_to_any(_FunRef, {Domain,Range}) -> + EmptySubstsDict = dict:new(), + NewDomain = [update_vars(A,EmptySubstsDict,true) || A <- Domain], + NewRange = update_vars(Range, EmptySubstsDict, true), + {NewDomain, NewRange}. + + +%%------------------------------------------------------------------------------ +%% ADT translation functions +%%------------------------------------------------------------------------------ + +-spec process_adts(mod_name(), mod_info()) -> mod_info(). +process_adts(Mod, + #mod_info{mod_exp_types = ModExpTypes, mod_opaques = ModOpaques, + mod_specs = ModExpSpecs} = ModInfo) -> + %% TODO: No warning on unexported opaques. + case sets:to_list(sets:intersection(ModExpTypes,ModOpaques)) of + [] -> + ModInfo; + ModADTs -> + %% TODO: No warning on unexported API functions. + ModExpSpecsList = [{Name,Domain,Range} + || {{Name,_Arity},{Domain,Range}} + <- dict:to_list(ModExpSpecs)], + AddADT = fun(ADT,Acc) -> add_adt(Mod,ADT,Acc,ModExpSpecsList) end, + lists:foldl(AddADT, ModInfo, ModADTs) + end. + +-spec add_adt(mod_name(), imm_type_ref(), mod_info(), [proc_fun_ref()]) -> + mod_info(). +add_adt(Mod, {Name,Arity}, #mod_info{mod_types = ModTypes} = ModInfo, + ModExpFunSpecs) -> + ADTRef = {type,Name,Arity}, + {abs_type,InternalRepr,VarNames,not_symb} = dict:fetch(ADTRef, ModTypes), + FullADTRef = {Mod,Name,Arity}, + %% TODO: No warning on unsuitable range. + SymbCalls1 = [get_symb_call(FullADTRef,Spec) || Spec <- ModExpFunSpecs], + %% TODO: No warning on bad use of variables. + SymbCalls2 = [fix_vars(FullADTRef,Call,RangeVars,VarNames) + || {ok,Call,RangeVars} <- SymbCalls1], + case [Call || {ok,Call} <- SymbCalls2] of + [] -> + %% TODO: No warning on no acceptable spec. + ModInfo; + SymbCalls3 -> + NewADTRepr = {abs_type,{type,0,union,SymbCalls3},VarNames, + {orig_abs,InternalRepr}}, + NewModTypes = dict:store(ADTRef, NewADTRepr, ModTypes), + ModInfo#mod_info{mod_types = NewModTypes} + end. + +-spec get_symb_call(full_imm_type_ref(), proc_fun_ref()) -> + tagged_result2(abs_type(),[var_name()]). +get_symb_call({Mod,_TypeName,_Arity} = FullADTRef, {FunName,Domain,Range}) -> + BaseCall = {type,0,tuple,[{atom,0,'$call'},{atom,0,Mod},{atom,0,FunName}, + {type,0,'$fixed_list',Domain}]}, + unwrap_range(FullADTRef, BaseCall, Range, false). + +-spec unwrap_range(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_range(FullADTRef, Call, {paren_type,_,[Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {ann_type,_,[_Var,Type]}, TestRun) -> + unwrap_range(FullADTRef, Call, Type, TestRun); +unwrap_range(FullADTRef, Call, {type,_,list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,maybe_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_list,[ElemType]}, TestRun) -> + unwrap_list(FullADTRef, Call, ElemType, TestRun); +unwrap_range(FullADTRef, Call, {type,_,nonempty_improper_list,[Cont,_Term]}, + TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(FullADTRef, Call, + {type,_,nonempty_maybe_improper_list,[Cont,_Term]}, TestRun) -> + unwrap_list(FullADTRef, Call, Cont, TestRun); +unwrap_range(_FullADTRef, _Call, {type,_,tuple,any}, _TestRun) -> + error; +unwrap_range(FullADTRef, Call, {type,_,tuple,FieldForms}, TestRun) -> + Translates = fun(T) -> unwrap_range(FullADTRef,none,T,true) =/= error end, + case proper_arith:find_first(Translates, FieldForms) of + none -> + error; + {TargetPos,TargetElem} -> + Pattern = get_pattern(TargetPos, FieldForms), + case TestRun of + true -> + NewCall = + case Call of + none -> {match_with,Pattern}; + _ -> Call + end, + {ok, NewCall, []}; + false -> + AbsPattern = term_to_singleton_type(Pattern), + NewCall = + {type,0,tuple, + [{atom,0,'$call'},{atom,0,?MODULE},{atom,0,match}, + {type,0,'$fixed_list',[AbsPattern,Call]}]}, + unwrap_range(FullADTRef, NewCall, TargetElem, TestRun) + end + end; +unwrap_range(FullADTRef, Call, {type,_,union,Choices}, TestRun) -> + TestedChoices = [unwrap_range(FullADTRef,none,C,true) || C <- Choices], + NotError = fun(error) -> false; (_) -> true end, + case proper_arith:find_first(NotError, TestedChoices) of + none -> + error; + {_ChoicePos,{ok,none,_RangeVars}} -> + error; + {ChoicePos,{ok,NextStep,_RangeVars}} -> + {A, [ChoiceElem|B]} = lists:split(ChoicePos-1, Choices), + OtherChoices = A ++ B, + DistinctChoice = + case NextStep of + take_head -> + fun cant_have_head/1; + {match_with,Pattern} -> + fun(C) -> cant_match(Pattern, C) end + end, + case {lists:all(DistinctChoice,OtherChoices), TestRun} of + {true,true} -> + {ok, NextStep, []}; + {true,false} -> + unwrap_range(FullADTRef, Call, ChoiceElem, TestRun); + {false,_} -> + error + end + end; +unwrap_range({_Mod,SameName,Arity}, Call, {type,_,SameName,ArgForms}, + _TestRun) -> + RangeVars = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(ArgForms) =:= Arity andalso length(RangeVars) =:= Arity of + true -> {ok, Call, RangeVars}; + false -> error + end; +unwrap_range({SameMod,SameName,_Arity} = FullADTRef, Call, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + TestRun) -> + unwrap_range(FullADTRef, Call, {type,0,SameName,ArgForms}, TestRun); +unwrap_range(_FullADTRef, _Call, _Range, _TestRun) -> + error. + +-spec unwrap_list(full_imm_type_ref(), abs_type() | next_step(), abs_type(), + boolean()) -> + tagged_result2(abs_type() | next_step(),[var_name()]). +unwrap_list(FullADTRef, Call, HeadType, TestRun) -> + NewCall = + case TestRun of + true -> + case Call of + none -> take_head; + _ -> Call + end; + false -> + {type,0,tuple,[{atom,0,'$call'},{atom,0,erlang},{atom,0,hd}, + {type,0,'$fixed_list',[Call]}]} + end, + unwrap_range(FullADTRef, NewCall, HeadType, TestRun). + +-spec fix_vars(full_imm_type_ref(), abs_type(), [var_name()], [var_name()]) -> + tagged_result(abs_type()). +fix_vars(FullADTRef, Call, RangeVars, VarNames) -> + NotAnyVar = fun(V) -> V =/= '_' end, + case no_duplicates(VarNames) andalso lists:all(NotAnyVar,VarNames) of + true -> + RawUsedVars = + collect_vars(FullADTRef, Call, [[V] || V <- RangeVars]), + UsedVars = [lists:usort(L) || L <- RawUsedVars], + case correct_var_use(UsedVars) of + true -> + PairAll = fun(L,Y) -> [{X,{var,0,Y}} || X <- L] end, + VarSubsts = + lists:flatten(lists:zipwith(PairAll,UsedVars,VarNames)), + VarSubstsDict = dict:from_list(VarSubsts), + {ok, update_vars(Call,VarSubstsDict,true)}; + false -> + error + end; + false -> + error + end. + +-spec no_duplicates(list()) -> boolean(). +no_duplicates(L) -> + length(lists:usort(L)) =:= length(L). + +-spec correct_var_use([[var_name() | 0]]) -> boolean(). +correct_var_use(UsedVars) -> + NoNonVarArgs = fun([0|_]) -> false; (_) -> true end, + lists:all(NoNonVarArgs, UsedVars) + andalso no_duplicates(lists:flatten(UsedVars)). + +-spec collect_vars(full_imm_type_ref(), abs_type(), [[var_name() | 0]]) -> + [[var_name() | 0]]. +collect_vars(FullADTRef, {paren_type,_,[Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(FullADTRef, {ann_type,_,[_Var,Type]}, UsedVars) -> + collect_vars(FullADTRef, Type, UsedVars); +collect_vars(_FullADTRef, {type,_,tuple,any}, UsedVars) -> + UsedVars; +collect_vars({_Mod,SameName,Arity} = FullADTRef, {type,_,SameName,ArgForms}, + UsedVars) -> + case length(ArgForms) =:= Arity of + true -> + VarArgs = [V || {var,_,V} <- ArgForms, V =/= '_'], + case length(VarArgs) =:= Arity of + true -> + AddToList = fun(X,L) -> [X | L] end, + lists:zipwith(AddToList, VarArgs, UsedVars); + false -> + [[0|L] || L <- UsedVars] + end; + false -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars) + end; +collect_vars(FullADTRef, {type,_,_Name,ArgForms}, UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars({SameMod,SameName,_Arity} = FullADTRef, + {remote_type,_,[{atom,_,SameMod},{atom,_,SameName},ArgForms]}, + UsedVars) -> + collect_vars(FullADTRef, {type,0,SameName,ArgForms}, UsedVars); +collect_vars(FullADTRef, {remote_type,_,[_RemModForm,_NameForm,ArgForms]}, + UsedVars) -> + multi_collect_vars(FullADTRef, ArgForms, UsedVars); +collect_vars(_FullADTRef, _Call, UsedVars) -> + UsedVars. + +-spec multi_collect_vars(full_imm_type_ref(), [abs_type()], + [[var_name() | 0]]) -> [[var_name() | 0]]. +multi_collect_vars({_Mod,_Name,Arity} = FullADTRef, Forms, UsedVars) -> + NoUsedVars = lists:duplicate(Arity, []), + MoreUsedVars = [collect_vars(FullADTRef,T,NoUsedVars) || T <- Forms], + CombineVars = fun(L1,L2) -> lists:zipwith(fun erlang:'++'/2, L1, L2) end, + lists:foldl(CombineVars, UsedVars, MoreUsedVars). + +-ifdef(NO_MODULES_IN_OPAQUES). +-type var_substs_dict() :: dict(). +-else. +-type var_substs_dict() :: dict:dict(var_name(),abs_type()). +-endif. +-spec update_vars(abs_type(), var_substs_dict(), boolean()) -> abs_type(). +update_vars({paren_type,Line,[Type]}, VarSubstsDict, UnboundToAny) -> + {paren_type, Line, [update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({ann_type,Line,[Var,Type]}, VarSubstsDict, UnboundToAny) -> + {ann_type, Line, [Var,update_vars(Type,VarSubstsDict,UnboundToAny)]}; +update_vars({var,Line,VarName} = Call, VarSubstsDict, UnboundToAny) -> + case dict:find(VarName, VarSubstsDict) of + {ok,SubstType} -> + SubstType; + error when UnboundToAny =:= false -> + Call; + error when UnboundToAny =:= true -> + {type,Line,any,[]} + end; +update_vars({remote_type,Line,[RemModForm,NameForm,ArgForms]}, VarSubstsDict, + UnboundToAny) -> + NewArgForms = [update_vars(A,VarSubstsDict,UnboundToAny) || A <- ArgForms], + {remote_type, Line, [RemModForm,NameForm,NewArgForms]}; +update_vars({type,_,tuple,any} = Call, _VarSubstsDict, _UnboundToAny) -> + Call; +update_vars({type,Line,Name,ArgForms}, VarSubstsDict, UnboundToAny) -> + {type, Line, Name, [update_vars(A,VarSubstsDict,UnboundToAny) + || A <- ArgForms]}; +update_vars(Call, _VarSubstsDict, _UnboundToAny) -> + Call. + + +%%------------------------------------------------------------------------------ +%% Match-related functions +%%------------------------------------------------------------------------------ + +-spec get_pattern(position(), [abs_type()]) -> pattern(). +get_pattern(TargetPos, FieldForms) -> + {0,RevPattern} = lists:foldl(fun add_field/2, {TargetPos,[]}, FieldForms), + list_to_tuple(lists:reverse(RevPattern)). + +-spec add_field(abs_type(), {non_neg_integer(),[pat_field()]}) -> + {non_neg_integer(),[pat_field(),...]}. +add_field(_Type, {1,Acc}) -> + {0, [1|Acc]}; +add_field({atom,_,Tag}, {Left,Acc}) -> + {erlang:max(0,Left-1), [Tag|Acc]}; +add_field(_Type, {Left,Acc}) -> + {erlang:max(0,Left-1), [0|Acc]}. + +%% @private +-spec match(pattern(), tuple()) -> term(). +match(Pattern, Term) when tuple_size(Pattern) =:= tuple_size(Term) -> + match(tuple_to_list(Pattern), tuple_to_list(Term), none, false); +match(_Pattern, _Term) -> + throw(no_match). + +-spec match([pat_field()], [term()], 'none' | {'ok',T}, boolean()) -> T. +match([], [], {ok,Target}, _TypeMode) -> + Target; +match([0|PatRest], [_|ToMatchRest], Acc, TypeMode) -> + match(PatRest, ToMatchRest, Acc, TypeMode); +match([1|PatRest], [Target|ToMatchRest], none, TypeMode) -> + match(PatRest, ToMatchRest, {ok,Target}, TypeMode); +match([Tag|PatRest], [X|ToMatchRest], Acc, TypeMode) when is_atom(Tag) -> + MatchesTag = + case TypeMode of + true -> can_be_tag(Tag, X); + false -> Tag =:= X + end, + case MatchesTag of + true -> match(PatRest, ToMatchRest, Acc, TypeMode); + false -> throw(no_match) + end. + +%% CAUTION: these must be sorted +-define(NON_ATOM_TYPES, + [arity,binary,bitstring,byte,char,float,'fun',function,integer,iodata, + iolist,list,maybe_improper_list,mfa,neg_integer,nil,no_return, + non_neg_integer,none,nonempty_improper_list,nonempty_list, + nonempty_maybe_improper_list,nonempty_string,number,pid,port, + pos_integer,range,record,reference,string,tuple]). +-define(NON_TUPLE_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,iodata,iolist,list,maybe_improper_list, + neg_integer,nil,no_return,node,non_neg_integer,none, + nonempty_improper_list,nonempty_list,nonempty_maybe_improper_list, + nonempty_string,number,pid,port,pos_integer,range,reference,string, + timeout]). +-define(NO_HEAD_TYPES, + [arity,atom,binary,bitstring,bool,boolean,byte,char,float,'fun', + function,identifier,integer,mfa,module,neg_integer,nil,no_return,node, + non_neg_integer,none,number,pid,port,pos_integer,range,record, + reference,timeout,tuple]). + +-spec can_be_tag(atom(), abs_type()) -> boolean(). +can_be_tag(Tag, {ann_type,_,[_Var,Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {paren_type,_,[Type]}) -> + can_be_tag(Tag, Type); +can_be_tag(Tag, {atom,_,Atom}) -> + Tag =:= Atom; +can_be_tag(_Tag, {integer,_,_Int}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg}) -> + false; +can_be_tag(_Tag, {op,_,_Op,_Arg1,_Arg2}) -> + false; +can_be_tag(Tag, {type,_,BName,[]}) when BName =:= bool; BName =:= boolean -> + is_boolean(Tag); +can_be_tag(Tag, {type,_,timeout,[]}) -> + Tag =:= infinity; +can_be_tag(Tag, {type,_,union,Choices}) -> + lists:any(fun(C) -> can_be_tag(Tag,C) end, Choices); +can_be_tag(_Tag, {type,_,Name,_Args}) -> + not ordsets:is_element(Name, ?NON_ATOM_TYPES); +can_be_tag(_Tag, _Type) -> + true. + +-spec cant_match(pattern(), abs_type()) -> boolean(). +cant_match(Pattern, {ann_type,_,[_Var,Type]}) -> + cant_match(Pattern, Type); +cant_match(Pattern, {paren_type,_,[Type]}) -> + cant_match(Pattern, Type); +cant_match(_Pattern, {atom,_,_Atom}) -> + true; +cant_match(_Pattern, {integer,_,_Int}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg}) -> + true; +cant_match(_Pattern, {op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_match(Pattern, {type,_,mfa,[]}) -> + cant_match(Pattern, {type,0,tuple,[{type,0,atom,[]},{type,0,atom,[]}, + {type,0,arity,[]}]}); +cant_match(Pattern, {type,_,union,Choices}) -> + lists:all(fun(C) -> cant_match(Pattern,C) end, Choices); +cant_match(_Pattern, {type,_,tuple,any}) -> + false; +cant_match(Pattern, {type,_,tuple,Fields}) -> + tuple_size(Pattern) =/= length(Fields) orelse + try match(tuple_to_list(Pattern), Fields, none, true) of + _ -> false + catch + throw:no_match -> true + end; +cant_match(_Pattern, {type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NON_TUPLE_TYPES); +cant_match(_Pattern, _Type) -> + false. + +-spec cant_have_head(abs_type()) -> boolean(). +cant_have_head({ann_type,_,[_Var,Type]}) -> + cant_have_head(Type); +cant_have_head({paren_type,_,[Type]}) -> + cant_have_head(Type); +cant_have_head({atom,_,_Atom}) -> + true; +cant_have_head({integer,_,_Int}) -> + true; +cant_have_head({op,_,_Op,_Arg}) -> + true; +cant_have_head({op,_,_Op,_Arg1,_Arg2}) -> + true; +cant_have_head({type,_,union,Choices}) -> + lists:all(fun cant_have_head/1, Choices); +cant_have_head({type,_,Name,_Args}) -> + ordsets:is_element(Name, ?NO_HEAD_TYPES); +cant_have_head(_Type) -> + false. + +%% Only covers atoms, integers and tuples, i.e. those that can be specified +%% through singleton types. +-spec term_to_singleton_type(atom() | integer() + | loose_tuple(atom() | integer())) -> abs_type(). +term_to_singleton_type(Atom) when is_atom(Atom) -> + {atom,0,Atom}; +term_to_singleton_type(Int) when is_integer(Int), Int >= 0 -> + {integer,0,Int}; +term_to_singleton_type(Int) when is_integer(Int), Int < 0 -> + {op,0,'-',{integer,0,-Int}}; +term_to_singleton_type(Tuple) when is_tuple(Tuple) -> + Fields = tuple_to_list(Tuple), + {type,0,tuple,[term_to_singleton_type(F) || F <- Fields]}. + + +%%------------------------------------------------------------------------------ +%% Instance testing functions +%%------------------------------------------------------------------------------ + +%% CAUTION: this must be sorted +-define(EQUIV_TYPES, + [{arity, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {bool, {type,0,boolean,[]}}, + {byte, {type,0,range,[{integer,0,0},{integer,0,255}]}}, + {char, {type,0,range,[{integer,0,0},{integer,0,16#10ffff}]}}, + {function, {type,0,'fun',[]}}, + {identifier, {type,0,union,[{type,0,pid,[]},{type,0,port,[]}, + {type,0,reference,[]}]}}, + {iodata, {type,0,union,[{type,0,binary,[]},{type,0,iolist,[]}]}}, + {iolist, {type,0,maybe_improper_list, + [{type,0,union,[{type,0,byte,[]},{type,0,binary,[]}, + {type,0,iolist,[]}]}, + {type,0,binary,[]}]}}, + {list, {type,0,list,[{type,0,any,[]}]}}, + {maybe_improper_list, {type,0,maybe_improper_list,[{type,0,any,[]}, + {type,0,any,[]}]}}, + {mfa, {type,0,tuple,[{type,0,atom,[]},{type,0,atom,[]}, + {type,0,arity,[]}]}}, + {node, {type,0,atom,[]}}, + {nonempty_list, {type,0,nonempty_list,[{type,0,any,[]}]}}, + {nonempty_maybe_improper_list, {type,0,nonempty_maybe_improper_list, + [{type,0,any,[]},{type,0,any,[]}]}}, + {nonempty_string, {type,0,nonempty_list,[{type,0,char,[]}]}}, + {string, {type,0,list,[{type,0,char,[]}]}}, + {term, {type,0,any,[]}}, + {timeout, {type,0,union,[{atom,0,infinity}, + {type,0,non_neg_integer,[]}]}}]). + +%% @private +%% TODO: Most of these functions accept an extended form of abs_type(), namely +%% the addition of a custom wrapper: {'from_mod',mod_name(),...} +-spec is_instance(term(), mod_name(), abs_type()) -> boolean(). +is_instance(X, Mod, TypeForm) -> + is_instance(X, Mod, TypeForm, []). + +-spec is_instance(term(), mod_name(), abs_type(), imm_stack()) -> boolean(). +is_instance(X, _Mod, {from_mod,OrigMod,Type}, Stack) -> + is_instance(X, OrigMod, Type, Stack); +is_instance(_X, _Mod, {var,_,'_'}, _Stack) -> + true; +is_instance(_X, _Mod, {var,_,Name}, _Stack) -> + %% All unconstrained spec vars have been replaced by 'any()' and we always + %% replace the variables on the RHS of types before recursing into them. + %% Provided that '-type' declarations contain no unbound variables, we + %% don't expect to find any non-'_' variables while recursing. + throw({'$typeserver',{unbound_var_in_type_declaration,Name}}); +is_instance(X, Mod, {ann_type,_,[_Var,Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {paren_type,_,[Type]}, Stack) -> + is_instance(X, Mod, Type, Stack); +is_instance(X, Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, + Stack) -> + is_custom_instance(X, Mod, RemMod, Name, ArgForms, true, Stack); +is_instance(SameAtom, _Mod, {atom,_,SameAtom}, _Stack) -> + true; +is_instance(SameInt, _Mod, {integer,_,SameInt}, _Stack) -> + true; +is_instance(X, _Mod, {op,_,_Op,_Arg} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(X, _Mod, {op,_,_Op,_Arg1,_Arg2} = Expr, _Stack) -> + is_int_const(X, Expr); +is_instance(_X, _Mod, {type,_,any,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,atom,[]}, _Stack) -> + is_atom(X); +is_instance(X, _Mod, {type,_,binary,[]}, _Stack) -> + is_binary(X); +is_instance(X, _Mod, {type,_,binary,[BaseExpr,UnitExpr]}, _Stack) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,Base} when Base >= 0 -> + case eval_int(UnitExpr) of + {ok,Unit} when Unit >= 0 -> + case is_bitstring(X) of + true -> + BitSizeX = bit_size(X), + case Unit =:= 0 of + true -> + BitSizeX =:= Base; + false -> + BitSizeX >= Base + andalso + (BitSizeX - Base) rem Unit =:= 0 + end; + false -> false + end; + _ -> + abs_expr_error(invalid_unit, UnitExpr) + end; + _ -> + abs_expr_error(invalid_base, BaseExpr) + end; +is_instance(X, _Mod, {type,_,bitstring,[]}, _Stack) -> + is_bitstring(X); +is_instance(X, _Mod, {type,_,boolean,[]}, _Stack) -> + is_boolean(X); +is_instance(X, _Mod, {type,_,float,[]}, _Stack) -> + is_float(X); +is_instance(X, _Mod, {type,_,'fun',[]}, _Stack) -> + is_function(X); +%% TODO: how to check range type? random inputs? special case for 0-arity? +is_instance(X, _Mod, {type,_,'fun',[{type,_,any,[]},_Range]}, _Stack) -> + is_function(X); +is_instance(X, _Mod, {type,_,'fun',[{type,_,product,Domain},_Range]}, _Stack) -> + is_function(X, length(Domain)); +is_instance(X, _Mod, {type,_,integer,[]}, _Stack) -> + is_integer(X); +is_instance(X, Mod, {type,_,list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, true, true, false); +is_instance(X, Mod, {type,_,maybe_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, true, true, true); +is_instance(X, _Mod, {type,_,module,[]}, _Stack) -> + is_atom(X) orelse + is_tuple(X) andalso X =/= {} andalso is_atom(element(1,X)); +is_instance([], _Mod, {type,_,nil,[]}, _Stack) -> + true; +is_instance(X, _Mod, {type,_,neg_integer,[]}, _Stack) -> + is_integer(X) andalso X < 0; +is_instance(X, _Mod, {type,_,non_neg_integer,[]}, _Stack) -> + is_integer(X) andalso X >= 0; +is_instance(X, Mod, {type,_,nonempty_list,[Type]}, _Stack) -> + list_test(X, Mod, Type, dummy, false, true, false); +is_instance(X, Mod, {type,_,nonempty_improper_list,[Cont,Term]}, _Stack) -> + list_test(X, Mod, Cont, Term, false, false, true); +is_instance(X, Mod, {type,_,nonempty_maybe_improper_list,[Cont,Term]}, + _Stack) -> + list_test(X, Mod, Cont, Term, false, true, true); +is_instance(X, _Mod, {type,_,number,[]}, _Stack) -> + is_number(X); +is_instance(X, _Mod, {type,_,pid,[]}, _Stack) -> + is_pid(X); +is_instance(X, _Mod, {type,_,port,[]}, _Stack) -> + is_port(X); +is_instance(X, _Mod, {type,_,pos_integer,[]}, _Stack) -> + is_integer(X) andalso X > 0; +is_instance(_X, _Mod, {type,_,product,_Elements}, _Stack) -> + throw({'$typeserver',{internal,product_in_is_instance}}); +is_instance(X, _Mod, {type,_,range,[LowExpr,HighExpr]}, _Stack) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + X >= Low andalso X =< High; + _ -> + abs_expr_error(invalid_range, LowExpr, HighExpr) + end; +is_instance(X, Mod, {type,_,record,[{atom,_,Name} = NameForm | RawSubsts]}, + Stack) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + SubstsDict = dict:from_list(Substs), + case get_type_repr(Mod, {record,Name,0}, false) of + {ok,{abs_record,OrigFields}} -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + is_instance(X, Mod, {type,0,tuple,[NameForm|Fields]}, Stack); + {error,Reason} -> + throw({'$typeserver',Reason}) + end; +is_instance(X, _Mod, {type,_,reference,[]}, _Stack) -> + is_reference(X); +is_instance(X, _Mod, {type,_,tuple,any}, _Stack) -> + is_tuple(X); +is_instance(X, Mod, {type,_,tuple,Fields}, _Stack) -> + is_tuple(X) andalso tuple_test(tuple_to_list(X), Mod, Fields); +is_instance(X, Mod, {type,_,union,Choices}, Stack) -> + IsInstance = fun(Choice) -> is_instance(X,Mod,Choice,Stack) end, + lists:any(IsInstance, Choices); +is_instance(X, Mod, {type,_,Name,[]}, Stack) -> + case orddict:find(Name, ?EQUIV_TYPES) of + {ok,EquivType} -> + is_instance(X, Mod, EquivType, Stack); + error -> + is_maybe_hard_adt(X, Mod, Name, [], Stack) + end; +is_instance(X, Mod, {type,_,Name,ArgForms}, Stack) -> + is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack); +is_instance(_X, _Mod, _Type, _Stack) -> + false. + +-spec is_int_const(term(), abs_expr()) -> boolean(). +is_int_const(X, Expr) -> + case eval_int(Expr) of + {ok,Int} -> + X =:= Int; + error -> + abs_expr_error(invalid_int_const, Expr) + end. + +%% TODO: We implicitly add the '| []' at the termination of maybe_improper_list. +%% TODO: We ignore a '[]' termination in improper_list. +-spec list_test(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_test(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper) -> + is_list(X) andalso + list_rec(X, Mod, Content, Termination, CanEmpty, CanProper, CanImproper). + +-spec list_rec(term(), mod_name(), abs_type(), 'dummy' | abs_type(), boolean(), + boolean(), boolean()) -> boolean(). +list_rec([], _Mod, _Content, _Termination, CanEmpty, CanProper, _CanImproper) -> + CanEmpty andalso CanProper; +list_rec([X | Rest], Mod, Content, Termination, _CanEmpty, CanProper, + CanImproper) -> + is_instance(X, Mod, Content, []) andalso + list_rec(Rest, Mod, Content, Termination, true, CanProper, CanImproper); +list_rec(X, Mod, _Content, Termination, _CanEmpty, _CanProper, CanImproper) -> + CanImproper andalso is_instance(X, Mod, Termination, []). + +-spec tuple_test([term()], mod_name(), [abs_type()]) -> boolean(). +tuple_test([], _Mod, []) -> + true; +tuple_test([X | XTail], Mod, [T | TTail]) -> + is_instance(X, Mod, T, []) andalso tuple_test(XTail, Mod, TTail); +tuple_test(_, _Mod, _) -> + false. + +-spec is_maybe_hard_adt(term(), mod_name(), type_name(), [abs_type()], + imm_stack()) -> boolean(). +is_maybe_hard_adt(X, Mod, Name, ArgForms, Stack) -> + case orddict:find({Name,length(ArgForms)}, ?HARD_ADTS) of + {ok,ADTMod} -> + is_custom_instance(X, Mod, ADTMod, Name, ArgForms, true, Stack); + error -> + is_custom_instance(X, Mod, Mod, Name, ArgForms, false, Stack) + end. + +-spec is_custom_instance(term(), mod_name(), mod_name(), type_name(), + [abs_type()], boolean(), imm_stack()) -> boolean(). +is_custom_instance(X, Mod, RemMod, Name, RawArgForms, IsRemote, Stack) -> + ArgForms = case Mod =/= RemMod of + true -> [{from_mod,Mod,A} || A <- RawArgForms]; + false -> RawArgForms + end, + Arity = length(ArgForms), + FullTypeRef = {RemMod,Name,Arity}, + case lists:member(FullTypeRef, Stack) of + true -> + throw({'$typeserver',{self_reference,FullTypeRef}}); + false -> + TypeRef = {type,Name,Arity}, + AbsType = get_abs_type(RemMod, TypeRef, ArgForms, IsRemote), + is_instance(X, RemMod, AbsType, [FullTypeRef|Stack]) + end. + +-spec get_abs_type(mod_name(), type_ref(), [abs_type()], boolean()) -> + abs_type(). +get_abs_type(RemMod, TypeRef, ArgForms, IsRemote) -> + case get_type_repr(RemMod, TypeRef, IsRemote) of + {ok,TypeRepr} -> + {FinalAbsType,SymbInfo,VarNames} = + case TypeRepr of + {cached,_FinType,FAT,SI} -> {FAT,SI,[]}; + {abs_type,FAT,VN,SI} -> {FAT,SI,VN} + end, + AbsType = + case SymbInfo of + not_symb -> FinalAbsType; + {orig_abs,OrigAbsType} -> OrigAbsType + end, + VarSubstsDict = dict:from_list(lists:zip(VarNames,ArgForms)), + update_vars(AbsType, VarSubstsDict, false); + {error,Reason} -> + throw({'$typeserver',Reason}) + end. + +-spec abs_expr_error(atom(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr) -> + {error,Reason} = expr_error(ImmReason, Expr), + throw({'$typeserver',Reason}). + +-spec abs_expr_error(atom(), abs_expr(), abs_expr()) -> no_return(). +abs_expr_error(ImmReason, Expr1, Expr2) -> + {error,Reason} = expr_error(ImmReason, Expr1, Expr2), + throw({'$typeserver',Reason}). + + +%%------------------------------------------------------------------------------ +%% Type translation functions +%%------------------------------------------------------------------------------ + +-spec convert(mod_name(), abs_type(), state()) -> + rich_result2(fin_type(),state()). +convert(Mod, TypeForm, State) -> + case convert(Mod, TypeForm, State, [], dict:new()) of + {ok,{simple,Type},NewState} -> + {ok, Type, NewState}; + {ok,{rec,_RecFun,_RecArgs},_NewState} -> + {error, {internal,rec_returned_to_toplevel}}; + {error,_Reason} = Error -> + Error + end. + +-spec convert(mod_name(), abs_type(), state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert(Mod, {paren_type,_,[Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(Mod, {ann_type,_,[_Var,Type]}, State, Stack, VarDict) -> + convert(Mod, Type, State, Stack, VarDict); +convert(_Mod, {var,_,'_'}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:any()}, State}; +convert(_Mod, {var,_,VarName}, State, _Stack, VarDict) -> + case dict:find(VarName, VarDict) of + %% TODO: do we need to check if we are at toplevel of a recursive? + {ok,RetType} -> {ok, RetType, State}; + error -> {error, {unbound_var,VarName}} + end; +convert(Mod, {remote_type,_,[{atom,_,RemMod},{atom,_,Name},ArgForms]}, State, + Stack, VarDict) -> + case prepare_for_remote(RemMod, Name, length(ArgForms), State) of + {ok,NewState} -> + convert_custom(Mod,RemMod,Name,ArgForms,NewState,Stack,VarDict); + {error,_Reason} = Error -> + Error + end; +convert(_Mod, {atom,_,Atom}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly(Atom)}, State}; +convert(_Mod, {integer,_,_Int} = IntExpr, State, _Stack, _VarDict) -> + convert_integer(IntExpr, State); +convert(_Mod, {op,_,_Op,_Arg} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {op,_,_Op,_Arg1,_Arg2} = OpExpr, State, _Stack, _VarDict) -> + convert_integer(OpExpr, State); +convert(_Mod, {type,_,binary,[BaseExpr,UnitExpr]}, State, _Stack, _VarDict) -> + %% <<_:X,_:_*Y>> means "bitstrings of X + k*Y bits, k >= 0" + case eval_int(BaseExpr) of + {ok,0} -> + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,proper_types:exactly(<<>>)}, State}; + {ok,1} -> {ok, {simple,proper_types:bitstring()}, State}; + {ok,8} -> {ok, {simple,proper_types:binary()}, State}; + {ok,N} when N > 0 -> + Gen = ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,Gen}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + {ok,Base} when Base > 0 -> + Head = proper_types:bitstring(Base), + case eval_int(UnitExpr) of + {ok,0} -> {ok, {simple,Head}, State}; + {ok,1} -> + Tail = proper_types:bitstring(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,8} -> + Tail = proper_types:binary(), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + {ok,N} when N > 0 -> + Tail = + ?LET(L, proper_types:list(proper_types:bitstring(N)), + concat_bitstrings(L)), + {ok, {simple,concat_binary_gens(Head, Tail)}, State}; + _ -> expr_error(invalid_unit, UnitExpr) + end; + _ -> + expr_error(invalid_base, BaseExpr) + end; +convert(_Mod, {type,_,range,[LowExpr,HighExpr]}, State, _Stack, _VarDict) -> + case {eval_int(LowExpr),eval_int(HighExpr)} of + {{ok,Low},{ok,High}} when Low =< High -> + {ok, {simple,proper_types:integer(Low,High)}, State}; + _ -> + expr_error(invalid_range, LowExpr, HighExpr) + end; +convert(_Mod, {type,_,nil,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:exactly([])}, State}; +convert(Mod, {type,_,list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, false, ElemForm, State, Stack, VarDict); +convert(Mod, {type,_,nonempty_list,[ElemForm]}, State, Stack, VarDict) -> + convert_list(Mod, true, ElemForm, State, Stack, VarDict); +convert(_Mod, {type,_,nonempty_list,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:list())}, State}; +convert(_Mod, {type,_,nonempty_string,[]}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:non_empty(proper_types:string())}, State}; +convert(_Mod, {type,_,tuple,any}, State, _Stack, _VarDict) -> + {ok, {simple,proper_types:tuple()}, State}; +convert(Mod, {type,_,tuple,ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, false, State, Stack, VarDict); +convert(Mod, {type,_,'$fixed_list',ElemForms}, State, Stack, VarDict) -> + convert_tuple(Mod, ElemForms, true, State, Stack, VarDict); +convert(Mod, {type,_,record,[{atom,_,Name}|FieldForms]}, State, Stack, + VarDict) -> + convert_record(Mod, Name, FieldForms, State, Stack, VarDict); +convert(Mod, {type,_,union,ChoiceForms}, State, Stack, VarDict) -> + convert_union(Mod, ChoiceForms, State, Stack, VarDict); +convert(Mod, {type,_,'fun',[{type,_,product,Domain},Range]}, State, Stack, + VarDict) -> + convert_fun(Mod, length(Domain), Range, State, Stack, VarDict); +%% TODO: These types should be replaced with accurate types. +%% TODO: Add support for nonempty_improper_list/2. +convert(Mod, {type,_,maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,0,list,[]}, State, Stack, VarDict); +convert(Mod, {type,_,maybe_improper_list,[Cont,_Ter]}, State, Stack, VarDict) -> + convert(Mod, {type,0,list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,_,nonempty_maybe_improper_list,[]}, State, Stack, VarDict) -> + convert(Mod, {type,0,nonempty_list,[]}, State, Stack, VarDict); +convert(Mod, {type,_,nonempty_maybe_improper_list,[Cont,_Term]}, State, Stack, + VarDict) -> + convert(Mod, {type,0,nonempty_list,[Cont]}, State, Stack, VarDict); +convert(Mod, {type,_,iodata,[]}, State, Stack, VarDict) -> + RealType = {type,0,union,[{type,0,binary,[]},{type,0,iolist,[]}]}, + convert(Mod, RealType, State, Stack, VarDict); +convert(Mod, {type,_,Name,[]}, State, Stack, VarDict) -> + case ordsets:is_element(Name, ?STD_TYPES_0) of + true -> + {ok, {simple,proper_types:Name()}, State}; + false -> + convert_maybe_hard_adt(Mod, Name, [], State, Stack, VarDict) + end; +convert(Mod, {type,_,Name,ArgForms}, State, Stack, VarDict) -> + convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict); +convert(_Mod, TypeForm, _State, _Stack, _VarDict) -> + {error, {unsupported_type,TypeForm}}. + +-spec concat_bitstrings([bitstring()]) -> bitstring(). +concat_bitstrings(BitStrings) -> + concat_bitstrings_tr(BitStrings, <<>>). + +-spec concat_bitstrings_tr([bitstring()], bitstring()) -> bitstring(). +concat_bitstrings_tr([], Acc) -> + Acc; +concat_bitstrings_tr([BitString | Rest], Acc) -> + concat_bitstrings_tr(Rest, <<Acc/bits,BitString/bits>>). + +-spec concat_binary_gens(fin_type(), fin_type()) -> fin_type(). +concat_binary_gens(HeadType, TailType) -> + ?LET({H,T}, {HeadType,TailType}, <<H/bits,T/bits>>). + +-spec convert_fun(mod_name(), arity(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_fun(Mod, Arity, Range, State, Stack, VarDict) -> + case convert(Mod, Range, State, ['fun' | Stack], VarDict) of + {ok,{simple,RangeType},NewState} -> + {ok, {simple,proper_types:function(Arity,RangeType)}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> convert_rec_fun(Arity, RecFun, RecArgs, NewState) + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_fun(arity(), rec_fun(), rec_args(), state()) -> + {'ok',ret_type(),state()}. +convert_rec_fun(Arity, RecFun, RecArgs, State) -> + %% We bind the generated value by size. + NewRecFun = + fun(GenFuns,Size) -> + proper_types:function(Arity, RecFun(GenFuns,Size)) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +-spec convert_list(mod_name(), boolean(), abs_type(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_list(Mod, NonEmpty, ElemForm, State, Stack, VarDict) -> + case convert(Mod, ElemForm, State, [list | Stack], VarDict) of + {ok,{simple,ElemType},NewState} -> + InnerType = proper_types:list(ElemType), + FinType = case NonEmpty of + true -> proper_types:non_empty(InnerType); + false -> InnerType + end, + {ok, {simple,FinType}, NewState}; + {ok,{rec,RecFun,RecArgs},NewState} -> + case {at_toplevel(RecArgs,Stack), NonEmpty} of + {true,true} -> + base_case_error(Stack); + {true,false} -> + NewRecFun = + fun(GenFuns,Size) -> + ElemGen = fun(S) -> ?LAZY(RecFun(GenFuns,S)) end, + proper_types:distlist(Size, ElemGen, false) + end, + NewRecArgs = clean_rec_args(RecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, NewState}; + {false,_} -> + {NewRecFun,NewRecArgs} = + convert_rec_list(RecFun, RecArgs, NonEmpty), + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_rec_list(RecFun, [{true,FullTypeRef}] = RecArgs, NonEmpty) -> + {NewRecFun,_NormalRecArgs} = + convert_normal_rec_list(RecFun, RecArgs, NonEmpty), + AltRecFun = + fun([InstListGen],Size) -> + InstTypesList = + proper_types:get_prop(internal_types, InstListGen(Size)), + proper_types:fixed_list([RecFun([fun(_Size) -> I end],0) + || I <- InstTypesList]) + end, + NewRecArgs = [{{list,NonEmpty,AltRecFun},FullTypeRef}], + {NewRecFun, NewRecArgs}; +convert_rec_list(RecFun, RecArgs, NonEmpty) -> + convert_normal_rec_list(RecFun, RecArgs, NonEmpty). + +-spec convert_normal_rec_list(rec_fun(), rec_args(), boolean()) -> + {rec_fun(),rec_args()}. +convert_normal_rec_list(RecFun, RecArgs, NonEmpty) -> + NewRecFun = fun(GenFuns,Size) -> + ElemGen = fun(S) -> RecFun(GenFuns, S) end, + proper_types:distlist(Size, ElemGen, NonEmpty) + end, + NewRecArgs = clean_rec_args(RecArgs), + {NewRecFun, NewRecArgs}. + +-spec convert_tuple(mod_name(), [abs_type()], boolean(), state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_tuple(Mod, ElemForms, ToList, State, Stack, VarDict) -> + case process_list(Mod, ElemForms, State, [tuple | Stack], VarDict) of + {ok,RetTypes,NewState} -> + case combine_ret_types(RetTypes, {tuple,ToList}) of + {simple,_FinType} = RetType -> + {ok, RetType, NewState}; + {rec,_RecFun,RecArgs} = RetType -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> {ok, RetType, NewState} + end + end; + {error,_Reason} = Error -> + Error + end. + +-spec convert_union(mod_name(), [abs_type()], state(), stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_union(Mod, ChoiceForms, State, Stack, VarDict) -> + case process_list(Mod, ChoiceForms, State, [union | Stack], VarDict) of + {ok,RawChoices,NewState} -> + ProcessChoice = fun(T,A) -> process_choice(T,A,Stack) end, + {RevSelfRecs,RevNonSelfRecs,RevNonRecs} = + lists:foldl(ProcessChoice, {[],[],[]}, RawChoices), + case {lists:reverse(RevSelfRecs),lists:reverse(RevNonSelfRecs), + lists:reverse(RevNonRecs)} of + {_SelfRecs,[],[]} -> + base_case_error(Stack); + {[],NonSelfRecs,NonRecs} -> + {ok, combine_ret_types(NonRecs ++ NonSelfRecs, union), + NewState}; + {SelfRecs,NonSelfRecs,NonRecs} -> + {BCaseRecFun,BCaseRecArgs} = + case combine_ret_types(NonRecs ++ NonSelfRecs, union) of + {simple,BCaseType} -> + {fun([],_Size) -> BCaseType end,[]}; + {rec,BCRecFun,BCRecArgs} -> + {BCRecFun,BCRecArgs} + end, + NumBCaseGens = length(BCaseRecArgs), + [ParentRef | _Upper] = Stack, + FallbackRecFun = fun([SelfGen],_Size) -> SelfGen(0) end, + FallbackRecArgs = [{false,ParentRef}], + FallbackRetType = {rec,FallbackRecFun,FallbackRecArgs}, + {rec,RCaseRecFun,RCaseRecArgs} = + combine_ret_types([FallbackRetType] ++ SelfRecs + ++ NonSelfRecs, wunion), + NewRecFun = + fun(AllGens,Size) -> + {BCaseGens,RCaseGens} = + lists:split(NumBCaseGens, AllGens), + case Size of + 0 -> BCaseRecFun(BCaseGens,0); + _ -> RCaseRecFun(RCaseGens,Size) + end + end, + NewRecArgs = BCaseRecArgs ++ RCaseRecArgs, + {ok, {rec,NewRecFun,NewRecArgs}, NewState} + end; + {error,_Reason} = Error -> + Error + end. + +-spec process_choice(ret_type(), {[ret_type()],[ret_type()],[ret_type()]}, + stack()) -> {[ret_type()],[ret_type()],[ret_type()]}. +process_choice({simple,_} = RetType, {SelfRecs,NonSelfRecs,NonRecs}, _Stack) -> + {SelfRecs, NonSelfRecs, [RetType | NonRecs]}; +process_choice({rec,RecFun,RecArgs}, {SelfRecs,NonSelfRecs,NonRecs}, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> + case partition_by_toplevel(RecArgs, Stack, true) of + {[],[],_,_} -> + NewRecArgs = clean_rec_args(RecArgs), + {[{rec,RecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs}; + {SelfRecArgs,SelfPos,OtherRecArgs,_OtherPos} -> + NumInstances = length(SelfRecArgs), + IsListInst = fun({true,_FTRef}) -> false + ; ({{list,_NE,_AltRecFun},_FTRef}) -> true + end, + NewRecFun = + case proper_arith:filter(IsListInst,SelfRecArgs) of + {[],[]} -> + no_list_inst_rec_fun(RecFun,NumInstances, + SelfPos); + {[{{list,NonEmpty,AltRecFun},_}],[ListInstPos]} -> + list_inst_rec_fun(AltRecFun,NumInstances, + SelfPos,NonEmpty,ListInstPos) + end, + [{_B,SelfRef} | _] = SelfRecArgs, + NewRecArgs = + [{false,SelfRef} | clean_rec_args(OtherRecArgs)], + {[{rec,NewRecFun,NewRecArgs} | SelfRecs], NonSelfRecs, + NonRecs} + end; + false -> + NewRecArgs = clean_rec_args(RecArgs), + {SelfRecs, [{rec,RecFun,NewRecArgs} | NonSelfRecs], NonRecs} + end. + +-spec no_list_inst_rec_fun(rec_fun(), pos_integer(), [position()]) -> rec_fun(). +no_list_inst_rec_fun(RecFun, NumInstances, SelfPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + Instances, + %% Size distribution will be a little off if both normal and + %% instance-accepting generators are present. + lists:duplicate(NumInstances, SelfGen(Size div NumInstances)), + begin + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + AllGens = proper_arith:insert(InstGens, SelfPos, OtherGens), + RecFun(AllGens, Size) + end) + end. + +-spec list_inst_rec_fun(rec_fun(), pos_integer(), [position()], boolean(), + position()) -> rec_fun(). +list_inst_rec_fun(AltRecFun, NumInstances, SelfPos, NonEmpty, ListInstPos) -> + fun([SelfGen|OtherGens], Size) -> + ?LETSHRINK( + AllInsts, + lists:duplicate(NumInstances - 1, SelfGen(Size div NumInstances)) + ++ proper_types:distlist(Size div NumInstances, SelfGen, NonEmpty), + begin + {Instances,InstList} = lists:split(NumInstances - 1, AllInsts), + InstGens = [fun(_Size) -> proper_types:exactly(I) end + || I <- Instances], + InstTypesList = [proper_types:exactly(I) || I <- InstList], + InstListGen = + fun(_Size) -> proper_types:fixed_list(InstTypesList) end, + AllInstGens = proper_arith:list_insert(ListInstPos, InstListGen, + InstGens), + AllGens = proper_arith:insert(AllInstGens, SelfPos, OtherGens), + AltRecFun(AllGens, Size) + end) + end. + +-spec convert_maybe_hard_adt(mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> + rich_result2(ret_type(),state()). +convert_maybe_hard_adt(Mod, Name, ArgForms, State, Stack, VarDict) -> + Arity = length(ArgForms), + case orddict:find({Name,Arity}, ?HARD_ADTS) of + {ok,Mod} -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict); + {ok,ADTMod} -> + ADT = {remote_type,0,[{atom,0,ADTMod},{atom,0,Name},ArgForms]}, + convert(Mod, ADT, State, Stack, VarDict); + error -> + convert_custom(Mod, Mod, Name, ArgForms, State, Stack, VarDict) + end. + +-spec convert_custom(mod_name(), mod_name(), type_name(), [abs_type()], state(), + stack(), var_dict()) -> rich_result2(ret_type(),state()). +convert_custom(Mod, RemMod, Name, ArgForms, State, Stack, VarDict) -> + case process_list(Mod, ArgForms, State, Stack, VarDict) of + {ok,Args,NewState} -> + Arity = length(Args), + TypeRef = {type,Name,Arity}, + FullTypeRef = {RemMod,type,Name,Args}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_record(mod_name(), type_name(), [abs_type()], state(), stack(), + var_dict()) -> rich_result2(ret_type(),state()). +convert_record(Mod, Name, RawSubsts, State, Stack, VarDict) -> + Substs = [{N,T} || {type,_,field_type,[{atom,_,N},T]} <- RawSubsts], + {SubstFields,SubstTypeForms} = lists:unzip(Substs), + case process_list(Mod, SubstTypeForms, State, Stack, VarDict) of + {ok,SubstTypes,NewState} -> + SubstsDict = dict:from_list(lists:zip(SubstFields, SubstTypes)), + TypeRef = {record,Name,0}, + FullTypeRef = {Mod,record,Name,SubstsDict}, + convert_type(TypeRef, FullTypeRef, NewState, Stack); + {error,_Reason} = Error -> + Error + end. + +-spec convert_type(type_ref(), full_type_ref(), state(), stack()) -> + rich_result2(ret_type(),state()). +convert_type(TypeRef, {Mod,_Kind,_Name,_Spec} = FullTypeRef, State, Stack) -> + case stack_position(FullTypeRef, Stack) of + none -> + case get_type_repr(Mod, TypeRef, false, State) of + {ok,TypeRepr,NewState} -> + convert_new_type(TypeRef, FullTypeRef, TypeRepr, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; + 1 -> + base_case_error(Stack); + _Pos -> + {ok, {rec,fun([Gen],Size) -> Gen(Size) end,[{true,FullTypeRef}]}, + State} + end. + +-spec convert_new_type(type_ref(), full_type_ref(), type_repr(), state(), + stack()) -> rich_result2(ret_type(),state()). +convert_new_type(_TypeRef, {_Mod,type,_Name,[]}, + {cached,FinType,_TypeForm,_SymbInfo}, State, _Stack) -> + {ok, {simple,FinType}, State}; +convert_new_type(TypeRef, {Mod,type,_Name,Args} = FullTypeRef, + {abs_type,TypeForm,Vars,SymbInfo}, State, Stack) -> + VarDict = dict:from_list(lists:zip(Vars, Args)), + case convert(Mod, TypeForm, State, [FullTypeRef | Stack], VarDict) of + {ok, {simple,ImmFinType}, NewState} -> + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + FinalState = case Vars of + [] -> cache_type(Mod, TypeRef, FinType, TypeForm, + SymbInfo, NewState); + _ -> NewState + end, + {ok, {simple,FinType}, FinalState}; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end; +convert_new_type(_TypeRef, {Mod,record,Name,SubstsDict} = FullTypeRef, + {abs_record,OrigFields}, State, Stack) -> + Fields = [case dict:find(FieldName, SubstsDict) of + {ok,NewFieldType} -> NewFieldType; + error -> OrigFieldType + end + || {FieldName,OrigFieldType} <- OrigFields], + case convert_tuple(Mod, [{atom,0,Name} | Fields], false, State, + [FullTypeRef | Stack], dict:new()) of + {ok, {simple,_FinType}, _NewState} = Result -> + Result; + {ok, {rec,RecFun,RecArgs}, NewState} -> + convert_maybe_rec(FullTypeRef, not_symb, RecFun, RecArgs, NewState, + Stack); + {error,_Reason} = Error -> + Error + end. + +-spec cache_type(mod_name(), type_ref(), fin_type(), abs_type(), symb_info(), + state()) -> state(). +cache_type(Mod, TypeRef, FinType, TypeForm, SymbInfo, + #state{types = Types} = State) -> + TypeRepr = {cached,FinType,TypeForm,SymbInfo}, + ModTypes = dict:fetch(Mod, Types), + NewModTypes = dict:store(TypeRef, TypeRepr, ModTypes), + NewTypes = dict:store(Mod, NewModTypes, Types), + State#state{types = NewTypes}. + +-spec convert_maybe_rec(full_type_ref(), symb_info(), rec_fun(), rec_args(), + state(), stack()) -> rich_result2(ret_type(),state()). +convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State, Stack) -> + case at_toplevel(RecArgs, Stack) of + true -> base_case_error(Stack); + false -> safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, + State) + end. + +-spec safe_convert_maybe_rec(full_type_ref(),symb_info(),rec_fun(),rec_args(), + state()) -> rich_result2(ret_type(),state()). +safe_convert_maybe_rec(FullTypeRef, SymbInfo, RecFun, RecArgs, State) -> + case partition_rec_args(FullTypeRef, RecArgs, false) of + {[],[],_,_} -> + {ok, {rec,RecFun,RecArgs}, State}; + {MyRecArgs,MyPos,OtherRecArgs,_OtherPos} -> + case lists:all(fun({B,_T}) -> B =:= false end, MyRecArgs) of + true -> convert_rec_type(SymbInfo, RecFun, MyPos, OtherRecArgs, + State); + false -> {error, {internal,true_rec_arg_reached_type}} + end + end. + +-spec convert_rec_type(symb_info(), rec_fun(), [position()], rec_args(), + state()) -> {ok, ret_type(), state()}. +convert_rec_type(SymbInfo, RecFun, MyPos, [], State) -> + NumRecArgs = length(MyPos), + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + RecFun(GenFuns, erlang:max(0,Size - 1)) + end + end, + SizedGen = y(M), + ImmFinType = ?SIZED(Size,SizedGen(Size + 1)), + FinType = case SymbInfo of + not_symb -> + ImmFinType; + {orig_abs,_OrigAbsType} -> + proper_symb:internal_well_defined(ImmFinType) + end, + {ok, {simple,FinType}, State}; +convert_rec_type(_SymbInfo, RecFun, MyPos, OtherRecArgs, State) -> + NumRecArgs = length(MyPos), + NewRecFun = + fun(OtherGens,TopSize) -> + M = fun(GenFun) -> + fun(Size) -> + GenFuns = lists:duplicate(NumRecArgs, GenFun), + AllGens = + proper_arith:insert(GenFuns, MyPos, OtherGens), + RecFun(AllGens, erlang:max(0,Size - 1)) + end + end, + (y(M))(TopSize) + end, + NewRecArgs = clean_rec_args(OtherRecArgs), + {ok, {rec,NewRecFun,NewRecArgs}, State}. + +%% Y Combinator: Read more at http://bc.tech.coop/blog/070611.html. +-spec y(fun((fun((T) -> S)) -> fun((T) -> S))) -> fun((T) -> S). +y(M) -> + G = fun(F) -> + M(fun(A) -> (F(F))(A) end) + end, + G(G). + +-spec process_list(mod_name(), [abs_type() | ret_type()], state(), stack(), + var_dict()) -> rich_result2([ret_type()],state()). +process_list(Mod, RawTypes, State, Stack, VarDict) -> + Process = fun({simple,_FinType} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + ({rec,_RecFun,_RecArgs} = Type, {ok,Types,State1}) -> + {ok, [Type|Types], State1}; + (TypeForm, {ok,Types,State1}) -> + case convert(Mod, TypeForm, State1, Stack, VarDict) of + {ok,Type,State2} -> {ok,[Type|Types],State2}; + {error,_} = Err -> Err + end; + (_RawType, {error,_} = Err) -> + Err + end, + case lists:foldl(Process, {ok,[],State}, RawTypes) of + {ok,RevTypes,NewState} -> + {ok, lists:reverse(RevTypes), NewState}; + {error,_Reason} = Error -> + Error + end. + +-spec convert_integer(abs_expr(), state()) -> rich_result2(ret_type(),state()). +convert_integer(Expr, State) -> + case eval_int(Expr) of + {ok,Int} -> {ok, {simple,proper_types:exactly(Int)}, State}; + error -> expr_error(invalid_int_const, Expr) + end. + +-spec eval_int(abs_expr()) -> tagged_result(integer()). +eval_int(Expr) -> + NoBindings = erl_eval:new_bindings(), + try erl_eval:expr(Expr, NoBindings) of + {value,Value,_NewBindings} when is_integer(Value) -> + {ok, Value}; + _ -> + error + catch + error:_ -> + error + end. + +-spec expr_error(atom(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr) -> + {error, {Reason,lists:flatten(erl_pp:expr(Expr))}}. + +-spec expr_error(atom(), abs_expr(), abs_expr()) -> {'error',term()}. +expr_error(Reason, Expr1, Expr2) -> + Str1 = lists:flatten(erl_pp:expr(Expr1)), + Str2 = lists:flatten(erl_pp:expr(Expr2)), + {error, {Reason,Str1,Str2}}. + +-spec base_case_error(stack()) -> {'error',term()}. +%% TODO: This might confuse, since it doesn't record the arguments to parametric +%% types or the type subsitutions of a record. +base_case_error([{Mod,type,Name,Args} | _Upper]) -> + Arity = length(Args), + {error, {no_base_case,{Mod,type,Name,Arity}}}; +base_case_error([{Mod,record,Name,_SubstsDict} | _Upper]) -> + {error, {no_base_case,{Mod,record,Name}}}. + + +%%------------------------------------------------------------------------------ +%% Helper datatypes handling functions +%%------------------------------------------------------------------------------ + +-spec stack_position(full_type_ref(), stack()) -> 'none' | pos_integer(). +stack_position(FullTypeRef, Stack) -> + SameType = fun(A) -> same_full_type_ref(A,FullTypeRef) end, + case proper_arith:find_first(SameType, Stack) of + {Pos,_} -> Pos; + none -> none + end. + +-spec partition_by_toplevel(rec_args(), stack(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_by_toplevel(RecArgs, [], _OnlyInstanceAccepting) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [_Parent | _Upper], _OnlyInstanceAccepting) + when is_atom(_Parent) -> + {[],[],RecArgs,lists:seq(1,length(RecArgs))}; +partition_by_toplevel(RecArgs, [Parent | _Upper], OnlyInstanceAccepting) -> + partition_rec_args(Parent, RecArgs, OnlyInstanceAccepting). + +-spec at_toplevel(rec_args(), stack()) -> boolean(). +at_toplevel(RecArgs, Stack) -> + case partition_by_toplevel(RecArgs, Stack, false) of + {[],[],_,_} -> false; + _ -> true + end. + +-spec partition_rec_args(full_type_ref(), rec_args(), boolean()) -> + {rec_args(),[position()],rec_args(),[position()]}. +partition_rec_args(FullTypeRef, RecArgs, OnlyInstanceAccepting) -> + SameType = + case OnlyInstanceAccepting of + true -> fun({false,_T}) -> false + ; ({_B,T}) -> same_full_type_ref(T,FullTypeRef) end; + false -> fun({_B,T}) -> same_full_type_ref(T,FullTypeRef) end + end, + proper_arith:partition(SameType, RecArgs). + +%% Tuples can be of 0 arity, unions of 1 and wunions at least of 2. +-spec combine_ret_types([ret_type()], {'tuple',boolean()} | 'union' + | 'wunion') -> ret_type(). +combine_ret_types(RetTypes, EnclosingType) -> + case lists:all(fun is_simple_ret_type/1, RetTypes) of + true -> + %% This should never happen for wunion. + Combine = case EnclosingType of + {tuple,false} -> fun proper_types:tuple/1; + {tuple,true} -> fun proper_types:fixed_list/1; + union -> fun proper_types:union/1 + end, + FinTypes = [T || {simple,T} <- RetTypes], + {simple, Combine(FinTypes)}; + false -> + NumTypes = length(RetTypes), + {RevRecFuns,RevRecArgsList,NumRecs} = + lists:foldl(fun add_ret_type/2, {[],[],0}, RetTypes), + RecFuns = lists:reverse(RevRecFuns), + RecArgsList = lists:reverse(RevRecArgsList), + RecArgLens = [length(RecArgs) || RecArgs <- RecArgsList], + RecFunInfo = {NumTypes,NumRecs,RecArgLens,RecFuns}, + FlatRecArgs = lists:flatten(RecArgsList), + {NewRecFun,NewRecArgs} = + case EnclosingType of + {tuple,ToList} -> + {tuple_rec_fun(RecFunInfo,ToList), + soft_clean_rec_args(FlatRecArgs,RecFunInfo,ToList)}; + union -> + {union_rec_fun(RecFunInfo),clean_rec_args(FlatRecArgs)}; + wunion -> + {wunion_rec_fun(RecFunInfo), + clean_rec_args(FlatRecArgs)} + end, + {rec, NewRecFun, NewRecArgs} + end. + +-spec tuple_rec_fun(rec_fun_info(), boolean()) -> rec_fun(). +tuple_rec_fun({_NumTypes,NumRecs,RecArgLens,RecFuns}, ToList) -> + Combine = case ToList of + true -> fun proper_types:fixed_list/1; + false -> fun proper_types:tuple/1 + end, + fun(AllGFs,TopSize) -> + Size = TopSize div NumRecs, + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun erlang:apply/2, + Combine(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec union_rec_fun(rec_fun_info()) -> rec_fun(). +union_rec_fun({_NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(F,A) -> ?LAZY(apply(F,A)) end, + proper_types:union(lists:zipwith(ZipFun, RecFuns, ArgsList)) + end. + +-spec wunion_rec_fun(rec_fun_info()) -> rec_fun(). +wunion_rec_fun({NumTypes,_NumRecs,RecArgLens,RecFuns}) -> + fun(AllGFs,Size) -> + GFsList = proper_arith:unflatten(AllGFs, RecArgLens), + ArgsList = [[GenFuns,Size] || GenFuns <- GFsList], + ZipFun = fun(W,F,A) -> {W,?LAZY(apply(F,A))} end, + RecWeight = erlang:max(1, Size div (NumTypes - 1)), + Weights = [1 | lists:duplicate(NumTypes - 1, RecWeight)], + WeightedChoices = lists:zipwith3(ZipFun, Weights, RecFuns, ArgsList), + proper_types:wunion(WeightedChoices) + end. + +-spec add_ret_type(ret_type(), {[rec_fun()],[rec_args()],non_neg_integer()}) -> + {[rec_fun()],[rec_args()],non_neg_integer()}. +add_ret_type({simple,FinType}, {RecFuns,RecArgsList,NumRecs}) -> + {[fun([],_) -> FinType end | RecFuns], [[] | RecArgsList], NumRecs}; +add_ret_type({rec,RecFun,RecArgs}, {RecFuns,RecArgsList,NumRecs}) -> + {[RecFun | RecFuns], [RecArgs | RecArgsList], NumRecs + 1}. + +-spec is_simple_ret_type(ret_type()) -> boolean(). +is_simple_ret_type({simple,_FinType}) -> + true; +is_simple_ret_type({rec,_RecFun,_RecArgs}) -> + false. + +-spec clean_rec_args(rec_args()) -> rec_args(). +clean_rec_args(RecArgs) -> + [{false,F} || {_B,F} <- RecArgs]. + +-spec soft_clean_rec_args(rec_args(), rec_fun_info(), boolean()) -> rec_args(). +soft_clean_rec_args(RecArgs, RecFunInfo, ToList) -> + soft_clean_rec_args_tr(RecArgs, [], RecFunInfo, ToList, false, 1). + +-spec soft_clean_rec_args_tr(rec_args(), rec_args(), rec_fun_info(), boolean(), + boolean(), position()) -> rec_args(). +soft_clean_rec_args_tr([], Acc, _RecFunInfo, _ToList, _FoundListInst, _Pos) -> + lists:reverse(Acc); +soft_clean_rec_args_tr([{{list,_NonEmpty,_AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, true, Pos) -> + NewArg = {false,FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([{{list,NonEmpty,AltRecFun},FTRef} | Rest], Acc, + RecFunInfo, ToList, false, Pos) -> + {NumTypes,NumRecs,RecArgLens,RecFuns} = RecFunInfo, + AltRecFunPos = get_group(Pos, RecArgLens), + AltRecFuns = proper_arith:list_update(AltRecFunPos, AltRecFun, RecFuns), + AltRecFunInfo = {NumTypes,NumRecs,RecArgLens,AltRecFuns}, + NewArg = {{list,NonEmpty,tuple_rec_fun(AltRecFunInfo,ToList)},FTRef}, + soft_clean_rec_args_tr(Rest, [NewArg|Acc], RecFunInfo, ToList, true, Pos+1); +soft_clean_rec_args_tr([Arg | Rest], Acc, RecFunInfo, ToList, FoundListInst, + Pos) -> + soft_clean_rec_args_tr(Rest, [Arg | Acc], RecFunInfo, ToList, FoundListInst, + Pos+1). + +-spec get_group(pos_integer(), [non_neg_integer()]) -> pos_integer(). +get_group(Pos, AllMembers) -> + get_group_tr(Pos, AllMembers, 1). + +-spec get_group_tr(pos_integer(), [non_neg_integer()], pos_integer()) -> + pos_integer(). +get_group_tr(Pos, [Members | Rest], GroupNum) -> + case Pos =< Members of + true -> GroupNum; + false -> get_group_tr(Pos - Members, Rest, GroupNum + 1) + end. + +-spec same_full_type_ref(full_type_ref(), term()) -> boolean(). +same_full_type_ref({SameMod,type,SameName,Args1}, + {SameMod,type,SameName,Args2}) -> + length(Args1) =:= length(Args2) + andalso lists:all(fun({A,B}) -> same_ret_type(A,B) end, + lists:zip(Args1, Args2)); +same_full_type_ref({SameMod,record,SameName,SubstsDict1}, + {SameMod,record,SameName,SubstsDict2}) -> + same_substs_dict(SubstsDict1, SubstsDict2); +same_full_type_ref(_, _) -> + false. + +-spec same_ret_type(ret_type(), ret_type()) -> boolean(). +same_ret_type({simple,FinType1}, {simple,FinType2}) -> + same_fin_type(FinType1, FinType2); +same_ret_type({rec,RecFun1,RecArgs1}, {rec,RecFun2,RecArgs2}) -> + NumRecArgs = length(RecArgs1), + length(RecArgs2) =:= NumRecArgs + andalso lists:all(fun({A1,A2}) -> same_rec_arg(A1,A2,NumRecArgs) end, + lists:zip(RecArgs1,RecArgs2)) + andalso same_rec_fun(RecFun1, RecFun2, NumRecArgs); +same_ret_type(_, _) -> + false. + +%% TODO: Is this too strict? +-spec same_rec_arg(rec_arg(), rec_arg(), arity()) -> boolean(). +same_rec_arg({{list,SameBool,AltRecFun1},FTRef1}, + {{list,SameBool,AltRecFun2},FTRef2}, NumRecArgs) -> + same_rec_fun(AltRecFun1, AltRecFun2, NumRecArgs) + andalso same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({true,FTRef1}, {true,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg({false,FTRef1}, {false,FTRef2}, _NumRecArgs) -> + same_full_type_ref(FTRef1, FTRef2); +same_rec_arg(_, _, _NumRecArgs) -> + false. + +-spec same_substs_dict(substs_dict(), substs_dict()) -> boolean(). +same_substs_dict(SubstsDict1, SubstsDict2) -> + SameKVPair = fun({{_K,V1},{_K,V2}}) -> same_ret_type(V1,V2); + (_) -> false + end, + SubstsKVList1 = lists:sort(dict:to_list(SubstsDict1)), + SubstsKVList2 = lists:sort(dict:to_list(SubstsDict2)), + length(SubstsKVList1) =:= length(SubstsKVList2) + andalso lists:all(SameKVPair, lists:zip(SubstsKVList1,SubstsKVList2)). + +-spec same_fin_type(fin_type(), fin_type()) -> boolean(). +same_fin_type(Type1, Type2) -> + proper_types:equal_types(Type1, Type2). + +-spec same_rec_fun(rec_fun(), rec_fun(), arity()) -> boolean(). +same_rec_fun(RecFun1, RecFun2, NumRecArgs) -> + %% It's ok that we return a type, even if there's a 'true' for use of + %% an instance. + GenFun = fun(_Size) -> proper_types:exactly('$dummy') end, + GenFuns = lists:duplicate(NumRecArgs,GenFun), + same_fin_type(RecFun1(GenFuns,0), RecFun2(GenFuns,0)). diff --git a/lib/dialyzer/test/small_SUITE_data/results/abs b/lib/dialyzer/test/small_SUITE_data/results/abs new file mode 100644 index 0000000000..f229a6d036 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/abs @@ -0,0 +1,9 @@ + +abs.erl:12: Function i1/0 has no local return +abs.erl:16: The pattern 'true' can never match the type 'false' +abs.erl:23: Function i2/0 has no local return +abs.erl:27: The pattern 'true' can never match the type 'false' +abs.erl:34: Function i3/0 has no local return +abs.erl:37: The pattern 'true' can never match the type 'false' +abs.erl:45: Function i4/0 has no local return +abs.erl:49: The pattern 'true' can never match the type 'false' diff --git a/lib/dialyzer/test/small_SUITE_data/src/abs.erl b/lib/dialyzer/test/small_SUITE_data/src/abs.erl new file mode 100644 index 0000000000..251e24cdfc --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/abs.erl @@ -0,0 +1,71 @@ +-module(abs). + +%% OTP-12948. erlang:abs/1 bug fix. + +-export([t/0]). + +t() -> + Fs = [fun i1/0, fun i2/0, fun i3/0, fun i4/0, fun f1/0], + _ = [catch F() || F <- Fs], + ok. + +i1() -> + A = int(), + I1 = i1(A), + true = I1 < 2, + true = I1 < 1. % can never match + +-spec i1(neg_integer()) -> non_neg_integer(). + +i1(A) when is_integer(A), A < 0 -> + abs(A). + +i2() -> + A = int(), + I2 = i2(A), + true = I2 < 1, + true = I2 < 0. % can never match + +-spec i2(non_neg_integer()) -> non_neg_integer(). + +i2(A) when is_integer(A), A >= 0 -> + abs(A). + +i3() -> + A = int(), + I3 = i3(A), + true = I3 < -1, + true = I3 < 0. % can never match + +-spec i3(integer()) -> non_neg_integer(). + +i3(A) when is_integer(A) -> + abs(A). + +i4() -> + A = int(), + I4 = i4(A), + true = I4 =:= 0 orelse I4 =:= 1, + true = I4 < 0 orelse I4 > 1. % can never match + +-spec i4(integer()) -> number(). + +i4(A) when A =:= -1; A =:= 0; A =:= 1 -> + abs(A). + +f1() -> + F1 = f1(float()), + math:sqrt(F1). + +f1(A) -> + abs(A). + +-spec int() -> integer(). + +int() -> + foo:bar(). + +-spec float() -> float(). + +float() -> + math:sqrt(1.0). diff --git a/lib/hipe/arm/hipe_arm_assemble.erl b/lib/hipe/arm/hipe_arm_assemble.erl index 7859e2d4a8..5f98c6593e 100644 --- a/lib/hipe/arm/hipe_arm_assemble.erl +++ b/lib/hipe/arm/hipe_arm_assemble.erl @@ -48,7 +48,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> DataRelocs = hipe_pack_constants:mk_data_relocs(RefsFromConsts, LabelMap), SSE = hipe_pack_constants:slim_sorted_exportmap(ExportMap,Closures,Exports), SlimRefs = hipe_pack_constants:slim_refs(AccRefs), - Bin = term_to_binary([{?VERSION_STRING(),?HIPE_SYSTEM_CRC}, + Bin = term_to_binary([{?VERSION_STRING(),?HIPE_ERTS_CHECKSUM}, ConstAlign, ConstSize, SC, DataRelocs, % nee LM, LabelMap diff --git a/lib/hipe/cerl/erl_bif_types.erl b/lib/hipe/cerl/erl_bif_types.erl index f49089d41c..5387edfb47 100644 --- a/lib/hipe/cerl/erl_bif_types.erl +++ b/lib/hipe/cerl/erl_bif_types.erl @@ -514,14 +514,15 @@ type(erlang, 'bsl', 2, Xs, Opaques) -> type(erlang, 'bnot', 1, Xs, Opaques) -> strict(erlang, 'bnot', 1, Xs, fun ([X1]) -> - case arith('bnot', X1, Opaques) of + case arith_bnot(X1, Opaques) of error -> t_integer(); {ok, T} -> T end end, Opaques); %% Guard bif, needs to be here. type(erlang, abs, 1, Xs, Opaques) -> - strict(erlang, abs, 1, Xs, fun ([X]) -> X end, Opaques); + strict(erlang, abs, 1, Xs, + fun ([X1]) -> arith_abs(X1, Opaques) end, Opaques); %% This returns (-X)-1, so it often gives a negative result. %% strict(erlang, 'bnot', 1, Xs, fun (_) -> t_integer() end, Opaques); type(erlang, append, 2, Xs, _Opaques) -> type(erlang, '++', 2, Xs); % alias @@ -1927,7 +1928,7 @@ negwidth(X, N) -> false -> negwidth(X, N+1) end. -arith('bnot', X1, Opaques) -> +arith_bnot(X1, Opaques) -> case t_is_integer(X1, Opaques) of false -> error; true -> @@ -1937,6 +1938,28 @@ arith('bnot', X1, Opaques) -> infinity_add(infinity_inv(Min1), -1))} end. +arith_abs(X1, Opaques) -> + case t_is_integer(X1, Opaques) of + false -> + case t_is_float(X1, Opaques) of + true -> t_float(); + false -> t_number() + end; + true -> + Min1 = number_min(X1, Opaques), + Max1 = number_max(X1, Opaques), + {NewMin, NewMax} = + case infinity_geq(Min1, 0) of + true -> {Min1, Max1}; + false -> + case infinity_geq(Max1, 0) of + true -> {0, infinity_inv(Min1)}; + false -> {infinity_inv(Max1), infinity_inv(Min1)} + end + end, + t_from_range(NewMin, NewMax) + end. + arith_mult(Min1, Max1, Min2, Max2) -> Tmp_list = [infinity_mult(Min1, Min2), infinity_mult(Min1, Max2), infinity_mult(Max1, Min2), infinity_mult(Max1, Max2)], diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 56ec757dbf..cd2d2fe207 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -2712,7 +2712,87 @@ is_compat_args([], []) -> true; is_compat_args(_, _) -> false. is_compat_arg(A, A) -> true; -is_compat_arg(A1, A2) -> t_is_any(A1) orelse t_is_any(A2). +is_compat_arg(A1, A2) -> + is_specialization(A1, A2) orelse is_specialization(A2, A1). + +-spec is_specialization(erl_type(), erl_type()) -> boolean(). + +%% Returns true if the first argument is a specialization of the +%% second argument in the sense that every type is a specialization of +%% any(). For example, {_,_} is a specialization of any(), but not of +%% tuple(). Does not handle variables, but any() and unions (sort of). + +is_specialization(_, ?any) -> true; +is_specialization(?any, _) -> false; +is_specialization(?function(Domain1, Range1), ?function(Domain2, Range2)) -> + (is_specialization(Domain1, Domain2) andalso + is_specialization(Range1, Range2)); +is_specialization(?list(Contents1, Termination1, Size1), + ?list(Contents2, Termination2, Size2)) -> + (Size1 =:= Size2 andalso + is_specialization(Contents1, Contents2) andalso + is_specialization(Termination1, Termination2)); +is_specialization(?product(Types1), ?product(Types2)) -> + specialization_list(Types1, Types2); +is_specialization(?tuple(?any, ?any, ?any), ?tuple(_, _, _)) -> false; +is_specialization(?tuple(_, _, _), ?tuple(?any, ?any, ?any)) -> false; +is_specialization(?tuple(Elements1, Arity, _), + ?tuple(Elements2, Arity, _)) when Arity =/= ?any -> + specialization_list(Elements1, Elements2); +is_specialization(?tuple_set([{Arity, List}]), + ?tuple(Elements2, Arity, _)) when Arity =/= ?any -> + specialization_list(sup_tuple_elements(List), Elements2); +is_specialization(?tuple(Elements1, Arity, _), + ?tuple_set([{Arity, List}])) when Arity =/= ?any -> + specialization_list(Elements1, sup_tuple_elements(List)); +is_specialization(?tuple_set(List1), ?tuple_set(List2)) -> + try + specialization_list(lists:append([T || {_Arity, T} <- List1]), + lists:append([T || {_Arity, T} <- List2])) + catch _:_ -> false + end; +is_specialization(?union(List1)=T1, ?union(List2)=T2) -> + case specialization_union2(T1, T2) of + {yes, Type1, Type2} -> is_specialization(Type1, Type2); + no -> specialization_list(List1, List2) + end; +is_specialization(?union(List), T2) -> + case unify_union(List) of + {yes, Type} -> is_specialization(Type, T2); + no -> false + end; +is_specialization(T1, ?union(List)) -> + case unify_union(List) of + {yes, Type} -> is_specialization(T1, Type); + no -> false + end; +is_specialization(?opaque(_) = T1, T2) -> + is_specialization(t_opaque_structure(T1), T2); +is_specialization(T1, ?opaque(_) = T2) -> + is_specialization(T1, t_opaque_structure(T2)); +is_specialization(?var(_), _) -> exit(error); +is_specialization(_, ?var(_)) -> exit(error); +is_specialization(T, T) -> true; +is_specialization(?none, _) -> false; +is_specialization(_, ?none) -> false; +is_specialization(?unit, _) -> false; +is_specialization(_, ?unit) -> false; +is_specialization(#c{}, #c{}) -> false. + +specialization_list(L1, L2) -> + length(L1) =:= length(L2) andalso specialization_list1(L1, L2). + +specialization_list1([], []) -> true; +specialization_list1([T1|L1], [T2|L2]) -> + is_specialization(T1, T2) andalso specialization_list1(L1, L2). + +specialization_union2(?union(List1)=T1, ?union(List2)=T2) -> + case {unify_union(List1), unify_union(List2)} of + {{yes, Type1}, {yes, Type2}} -> {yes, Type1, Type2}; + {{yes, Type1}, no} -> {yes, Type1, T2}; + {no, {yes, Type2}} -> {yes, T1, Type2}; + {no, no} -> no + end. -spec t_inf_lists([erl_type()], [erl_type()]) -> [erl_type()]. diff --git a/lib/hipe/llvm/hipe_llvm_merge.erl b/lib/hipe/llvm/hipe_llvm_merge.erl index 3ababfc21a..6e891ac3b0 100644 --- a/lib/hipe/llvm/hipe_llvm_merge.erl +++ b/lib/hipe/llvm/hipe_llvm_merge.erl @@ -27,7 +27,7 @@ finalize(CompiledCode, Closures, Exports) -> DataRelocs = hipe_pack_constants:mk_data_relocs(RefsFromConsts, LabelMap), SSE = hipe_pack_constants:slim_sorted_exportmap(ExportMap, Closures, Exports), SlimRefs = hipe_pack_constants:slim_refs(AccRefs), - term_to_binary([{?VERSION_STRING(),?HIPE_SYSTEM_CRC}, + term_to_binary([{?VERSION_STRING(),?HIPE_ERTS_CHECKSUM}, ConstAlign, ConstSize, SC, % ConstMap DataRelocs, % LabelMap diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src index 008393e63c..aa86b6dc5b 100644 --- a/lib/hipe/main/hipe.app.src +++ b/lib/hipe/main/hipe.app.src @@ -225,4 +225,4 @@ {applications, [kernel,stdlib]}, {env, []}, {runtime_dependencies, ["syntax_tools-1.6.14","stdlib-2.5","kernel-3.0", - "erts-7.0","compiler-5.0"]}]}. + "erts-7.1","compiler-5.0"]}]}. diff --git a/lib/hipe/main/hipe.erl b/lib/hipe/main/hipe.erl index ce4f49ffa7..1a4bbf179f 100644 --- a/lib/hipe/main/hipe.erl +++ b/lib/hipe/main/hipe.erl @@ -208,7 +208,8 @@ help_options/0, help_option/1, help_debug_options/0, - version/0]). + version/0, + erts_checksum/0]). -ifndef(DEBUG). -define(DEBUG,true). @@ -216,6 +217,7 @@ -include("hipe.hrl"). -include("../../compiler/src/beam_disasm.hrl"). +-include("../rtl/hipe_literals.hrl"). %%------------------------------------------------------------------- %% Basic type declaration for exported functions of the 'hipe' module @@ -1032,6 +1034,12 @@ post(Res, Icode, Options) -> version() -> ?VERSION_STRING(). +%% @doc Returns checksum identifying the target runtime system. +-spec erts_checksum() -> integer(). + +erts_checksum() -> + ?HIPE_ERTS_CHECKSUM. + %% -------------------------------------------------------------------- %% D O C U M E N T A T I O N - H E L P %% -------------------------------------------------------------------- @@ -1062,6 +1070,8 @@ help() -> " Prints a description of debug options.\n" ++ " version() ->\n" ++ " Returns the HiPE version as a string'.\n" ++ + " erts_checksum() ->\n" ++ + " Returns a checksum identifying the target runtime system.\n" ++ "\n" ++ " For HiPE developers only:\n" ++ " Use `help_hiper()' for information about HiPE's low-level interface\n", diff --git a/lib/hipe/ppc/hipe_ppc_assemble.erl b/lib/hipe/ppc/hipe_ppc_assemble.erl index 4d419978ef..00f28d60e4 100644 --- a/lib/hipe/ppc/hipe_ppc_assemble.erl +++ b/lib/hipe/ppc/hipe_ppc_assemble.erl @@ -50,7 +50,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> DataRelocs = hipe_pack_constants:mk_data_relocs(RefsFromConsts, LabelMap), SSE = hipe_pack_constants:slim_sorted_exportmap(ExportMap,Closures,Exports), SlimRefs = hipe_pack_constants:slim_refs(AccRefs), - Bin = term_to_binary([{?VERSION_STRING(),?HIPE_SYSTEM_CRC}, + Bin = term_to_binary([{?VERSION_STRING(),?HIPE_ERTS_CHECKSUM}, ConstAlign, ConstSize, SC, DataRelocs, % nee LM, LabelMap diff --git a/lib/hipe/sparc/hipe_sparc_assemble.erl b/lib/hipe/sparc/hipe_sparc_assemble.erl index 5424a6c965..0e27c78416 100644 --- a/lib/hipe/sparc/hipe_sparc_assemble.erl +++ b/lib/hipe/sparc/hipe_sparc_assemble.erl @@ -49,7 +49,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> DataRelocs = hipe_pack_constants:mk_data_relocs(RefsFromConsts, LabelMap), SSE = hipe_pack_constants:slim_sorted_exportmap(ExportMap,Closures,Exports), SlimRefs = hipe_pack_constants:slim_refs(AccRefs), - Bin = term_to_binary([{?VERSION_STRING(),?HIPE_SYSTEM_CRC}, + Bin = term_to_binary([{?VERSION_STRING(),?HIPE_ERTS_CHECKSUM}, ConstAlign, ConstSize, SC, DataRelocs, % nee LM, LabelMap diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index 4ffa3d35ba..695ce16887 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -83,7 +83,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> DataRelocs = hipe_pack_constants:mk_data_relocs(RefsFromConsts, LabelMap), SSE = hipe_pack_constants:slim_sorted_exportmap(ExportMap,Closures,Exports), SlimRefs = hipe_pack_constants:slim_refs(AccRefs), - Bin = term_to_binary([{?VERSION_STRING(),?HIPE_SYSTEM_CRC}, + Bin = term_to_binary([{?VERSION_STRING(),?HIPE_ERTS_CHECKSUM}, ConstAlign, ConstSize, SC, DataRelocs, % nee LM, LabelMap diff --git a/lib/inets/src/http_lib/http_transport.erl b/lib/inets/src/http_lib/http_transport.erl index bbe3ec9e4c..719dc4c425 100644 --- a/lib/inets/src/http_lib/http_transport.erl +++ b/lib/inets/src/http_lib/http_transport.erl @@ -269,7 +269,7 @@ get_socket_info(Addr, Port, Fd) -> undefined -> {Port, sock_opts(Addr, BaseOpts)}; Fd -> - {0, sock_opts(Addr, [{fd, Fd} | BaseOpts])} + {0, sock_opts([{fd, Fd} | BaseOpts])} end. %%------------------------------------------------------------------------- diff --git a/lib/inets/src/http_server/httpd_sup.erl b/lib/inets/src/http_server/httpd_sup.erl index de08624d44..f0b1942e2f 100644 --- a/lib/inets/src/http_server/httpd_sup.erl +++ b/lib/inets/src/http_server/httpd_sup.erl @@ -185,12 +185,16 @@ httpd_child_spec(ConfigFile, AcceptTimeoutDef, DebugDef) -> end. httpd_child_spec(Config, AcceptTimeout, Debug, Addr, Port, Profile) -> - Fd = proplists:get_value(fd, Config, undefined), - case Port == 0 orelse Fd =/= undefined of - true -> - httpd_child_spec_listen(Config, AcceptTimeout, Debug, Addr, Port, Profile); - false -> - httpd_child_spec_nolisten(Config, AcceptTimeout, Debug, Addr, Port, Profile) + case get_fd(Port) of + {ok, Fd} -> + case Port == 0 orelse Fd =/= undefined of + true -> + httpd_child_spec_listen(Config, AcceptTimeout, Debug, Addr, Port, Profile); + false -> + httpd_child_spec_nolisten(Config, AcceptTimeout, Debug, Addr, Port, Profile) + end; + Error -> + Error end. httpd_child_spec_listen(Config, AcceptTimeout, Debug, Addr, Port, Profile) -> @@ -236,7 +240,7 @@ listen(Address, Port, Config) -> SocketType -> case http_transport:start(SocketType) of ok -> - Fd = proplists:get_value(fd, Config), + {ok, Fd} = get_fd(Port), IpFamily = proplists:get_value(ipfamily, Config, inet6fb4), case http_transport:listen(SocketType, Address, Port, Fd, IpFamily) of {ok, ListenSocket} -> @@ -355,3 +359,19 @@ ssl_ca_certificate_file(Config) -> File -> [{cacertfile, File}] end. + +get_fd(0) -> + {ok, undefined}; +get_fd(Port) -> + FdKey = list_to_atom("httpd_" ++ integer_to_list(Port)), + case init:get_argument(FdKey) of + {ok, [[Value]]} -> + case (catch list_to_integer(Value)) of + N when is_integer(N) -> + {ok, N}; + _ -> + {error, {bad_descriptor, Value}} + end; + _ -> + {ok, undefined} + end. diff --git a/lib/inets/src/tftp/tftp_engine.erl b/lib/inets/src/tftp/tftp_engine.erl index fa44cd61ce..d0510e795b 100644 --- a/lib/inets/src/tftp/tftp_engine.erl +++ b/lib/inets/src/tftp/tftp_engine.erl @@ -128,8 +128,8 @@ daemon_start(Options) when is_list(Options) -> daemon_init(Config) when is_record(Config, config), is_pid(Config#config.parent_pid) -> process_flag(trap_exit, true), - UdpOptions = prepare_daemon_udp(Config), - case catch gen_udp:open(Config#config.udp_port, UdpOptions) of + {Port, UdpOptions} = prepare_daemon_udp(Config), + case catch gen_udp:open(Port, UdpOptions) of {ok, Socket} -> {ok, ActualPort} = inet:port(Socket), proc_lib:init_ack({ok, self()}), @@ -157,7 +157,7 @@ prepare_daemon_udp(#config{udp_port = Port, udp_options = UdpOptions} = Config) case lists:keymember(fd, 1, UdpOptions) of true -> %% Use explicit fd - UdpOptions; + {Port, UdpOptions}; false -> %% Use fd from setuid_socket_wrap, such as -tftpd_69 InitArg = list_to_atom("tftpd_" ++ integer_to_list(Port)), @@ -165,7 +165,7 @@ prepare_daemon_udp(#config{udp_port = Port, udp_options = UdpOptions} = Config) {ok, [[FdStr]] = Badarg} when is_list(FdStr) -> case catch list_to_integer(FdStr) of Fd when is_integer(Fd) -> - [{fd, Fd} | UdpOptions]; + {0, [{fd, Fd} | lists:keydelete(ip, 1, UdpOptions)]}; {'EXIT', _} -> Text = lists:flatten(io_lib:format("Illegal prebound fd ~p: ~p", [InitArg, Badarg])), print_debug_info(Config, daemon, open, ?ERROR(open, undef, Text, "")), @@ -176,7 +176,7 @@ prepare_daemon_udp(#config{udp_port = Port, udp_options = UdpOptions} = Config) print_debug_info(Config, daemon, open, ?ERROR(open, undef, Text, "")), exit({badarg, {prebound_fd, InitArg, Badarg}}); error -> - UdpOptions + {Port, UdpOptions} end end. diff --git a/lib/inets/test/Makefile b/lib/inets/test/Makefile index cae77a05f3..607ec7c182 100644 --- a/lib/inets/test/Makefile +++ b/lib/inets/test/Makefile @@ -174,7 +174,8 @@ MODULES = \ inets_appup_test \ tftp_test_lib \ tftp_SUITE \ - uri_SUITE + uri_SUITE \ + inets_socketwrap_SUITE EBIN = . @@ -203,7 +204,7 @@ INETS_FILES = inets.config $(INETS_SPECS) # inets_ftp_suite \ # inets_tftp_suite -INETS_DATADIRS = inets_SUITE_data inets_sup_SUITE_data +INETS_DATADIRS = inets_SUITE_data inets_socketwrap_SUITE_data HTTPD_DATADIRS = httpd_test_data httpd_SUITE_data httpd_basic_SUITE_data old_httpd_SUITE_data HTTPC_DATADIRS = httpc_SUITE_data httpc_proxy_SUITE_data FTP_DATADIRS = ftp_SUITE_data @@ -250,7 +251,7 @@ ERL_COMPILE_FLAGS += \ # 1) INETS_PRIV_DIR must be created # ---------------------------------------------------- -tests debug opt: $(BUILDTARGET) +tests debug opt: $(BUILDTARGET) targets: $(TARGET_FILES) diff --git a/lib/inets/test/inets_SUITE.erl b/lib/inets/test/inets_SUITE.erl index c3586f09e3..928d9dc391 100644 --- a/lib/inets/test/inets_SUITE.erl +++ b/lib/inets/test/inets_SUITE.erl @@ -21,7 +21,6 @@ -module(inets_SUITE). -include_lib("common_test/include/ct.hrl"). --include("test_server_line.hrl"). -include("inets_test_lib.hrl"). %% Note: This directive should only be used in test suites. @@ -37,8 +36,12 @@ all() -> groups() -> [{services_test, [], - [start_inets, start_httpc, start_httpd, start_ftpc, - start_tftpd]}, + [start_inets, + start_httpc, + start_httpd, + start_ftpc, + start_tftpd + ]}, {app_test, [], [{inets_app_test, all}]}, {appup_test, [], [{inets_appup_test, all}]}]. @@ -48,9 +51,6 @@ init_per_group(_GroupName, Config) -> end_per_group(_GroupName, Config) -> Config. - - - %%-------------------------------------------------------------------- %% Function: init_per_suite(Config) -> Config %% Config - [tuple()] @@ -103,14 +103,8 @@ end_per_testcase(_, Config) -> %% Test cases starts here. %%------------------------------------------------------------------------- - - -%%------------------------------------------------------------------------- - -start_inets(doc) -> - ["Test inets API functions"]; -start_inets(suite) -> - []; +start_inets() -> + [{doc, "Test inets API functions"}]. start_inets(Config) when is_list(Config) -> [_|_] = inets:service_names(), @@ -134,134 +128,85 @@ start_inets(Config) when is_list(Config) -> ok = inets:start(permanent), ok = inets:stop(). - %%------------------------------------------------------------------------- -start_httpc(doc) -> - ["Start/stop of httpc service"]; -start_httpc(suite) -> - []; +start_httpc() -> + [{doc, "Start/stop of httpc service"}]. start_httpc(Config) when is_list(Config) -> process_flag(trap_exit, true), - tsp("start_httpc -> entry with" - "~n Config: ~p", [Config]), - PrivDir = ?config(priv_dir, Config), - tsp("start_httpc -> start (empty) inets"), ok = inets:start(), - - tsp("start_httpc -> start httpc (as inets service) with profile foo"), {ok, Pid0} = inets:start(httpc, [{profile, foo}]), - tsp("start_httpc -> check running services"), Pids0 = [ServicePid || {_, ServicePid} <- inets:services()], true = lists:member(Pid0, Pids0), [_|_] = inets:services_info(), - tsp("start_httpc -> stop httpc"), inets:stop(httpc, Pid0), - tsp("start_httpc -> sleep some"), test_server:sleep(100), - tsp("start_httpc -> check running services"), Pids1 = [ServicePid || {_, ServicePid} <- inets:services()], false = lists:member(Pid0, Pids1), - tsp("start_httpc -> start httpc (stand-alone) with profile bar"), {ok, Pid1} = inets:start(httpc, [{profile, bar}], stand_alone), - tsp("start_httpc -> check running services"), Pids2 = [ServicePid || {_, ServicePid} <- inets:services()], false = lists:member(Pid1, Pids2), - tsp("start_httpc -> stop httpc"), ok = inets:stop(stand_alone, Pid1), receive {'EXIT', Pid1, shutdown} -> ok after 100 -> - tsf(stand_alone_not_shutdown) + ct:fail(stand_alone_not_shutdown) end, - tsp("start_httpc -> stop inets"), ok = inets:stop(), - tsp("start_httpc -> unload inets"), application:load(inets), - - tsp("start_httpc -> set inets environment (httpc profile foo)"), application:set_env(inets, services, [{httpc,[{profile, foo}, {data_dir, PrivDir}]}]), - - tsp("start_httpc -> start inets"), ok = inets:start(), - tsp("start_httpc -> check running services"), (?NUM_DEFAULT_SERVICES + 1) = length(inets:services()), - tsp("start_httpc -> unset inets env"), application:unset_env(inets, services), - - tsp("start_httpc -> stop inets"), ok = inets:stop(), - - tsp("start_httpc -> start (empty) inets"), ok = inets:start(), - tsp("start_httpc -> start inets httpc service with profile foo"), {ok, Pid3} = inets:start(httpc, [{profile, foo}]), - - tsp("start_httpc -> stop inets service httpc with profile foo"), ok = inets:stop(httpc, foo), - - tsp("start_httpc -> check running services"), Pids3 = [ServicePid || {_, ServicePid} <- inets:services()], false = lists:member(Pid3, Pids3), - - tsp("start_httpc -> stop inets"), - ok = inets:stop(), - - tsp("start_httpc -> done"), - ok. - + ok = inets:stop(). %%------------------------------------------------------------------------- -start_httpd(doc) -> - ["Start/stop of httpd service"]; -start_httpd(suite) -> - []; +start_httpd() -> + [{doc, "Start/stop of httpd service"}]. start_httpd(Config) when is_list(Config) -> process_flag(trap_exit, true), - i("start_httpd -> entry with" - "~n Config: ~p", [Config]), PrivDir = ?config(priv_dir, Config), HttpdConf = [{server_name, "httpd_test"}, {server_root, PrivDir}, - {document_root, PrivDir}, {bind_address, "localhost"}], + {document_root, PrivDir}, {bind_address, any}], - i("start_httpd -> start inets"), ok = inets:start(), - - i("start_httpd -> start httpd service"), {ok, Pid0} = inets:start(httpd, [{port, 0}, {ipfamily, inet} | HttpdConf]), Pids0 = [ServicePid || {_, ServicePid} <- inets:services()], true = lists:member(Pid0, Pids0), [_|_] = inets:services_info(), - i("start_httpd -> stop httpd service"), inets:stop(httpd, Pid0), test_server:sleep(500), Pids1 = [ServicePid || {_, ServicePid} <- inets:services()], false = lists:member(Pid0, Pids1), - i("start_httpd -> start (stand-alone) httpd service"), {ok, Pid1} = inets:start(httpd, [{port, 0}, {ipfamily, inet} | HttpdConf], stand_alone), Pids2 = [ServicePid || {_, ServicePid} <- inets:services()], false = lists:member(Pid1, Pids2), - i("start_httpd -> stop (stand-alone) httpd service"), ok = inets:stop(stand_alone, Pid1), receive {'EXIT', Pid1, shutdown} -> @@ -269,7 +214,6 @@ start_httpd(Config) when is_list(Config) -> after 100 -> test_server:fail(stand_alone_not_shutdown) end, - i("start_httpd -> stop inets"), ok = inets:stop(), File0 = filename:join(PrivDir, "httpd.conf"), {ok, Fd0} = file:open(File0, [write]), @@ -277,17 +221,12 @@ start_httpd(Config) when is_list(Config) -> ok = file:write(Fd0, Str), file:close(Fd0), - i("start_httpd -> [application] load inets"), application:load(inets), - i("start_httpd -> [application] set httpd services env with proplist-file"), application:set_env(inets, services, [{httpd, [{proplist_file, File0}]}]), - i("start_httpd -> start inets"), ok = inets:start(), (?NUM_DEFAULT_SERVICES + 1) = length(inets:services()), - i("start_httpd -> [application] unset services env"), application:unset_env(inets, services), - i("start_httpd -> stop inets"), ok = inets:stop(), File1 = filename:join(PrivDir, "httpd_apache.conf"), @@ -300,68 +239,46 @@ start_httpd(Config) when is_list(Config) -> file:write(Fd1, "Port 0\r\n"), file:close(Fd1), - i("start_httpd -> [application] load inets"), application:load(inets), - i("start_httpd -> [application] set httpd services env with file"), application:set_env(inets, services, [{httpd, [{file, File1}]}]), - i("start_httpd -> start inets"), ok = inets:start(), (?NUM_DEFAULT_SERVICES + 1) = length(inets:services()), - i("start_httpd -> [application] unset services env"), application:unset_env(inets, services), - i("start_httpd -> stop inets"), ok = inets:stop(), %% OLD format - i("start_httpd -> [application] load inets"), application:load(inets), - i("start_httpd -> [application] set httpd services OLD env"), application:set_env(inets, services, [{httpd, File1}]), - i("start_httpd -> start inets"), ok = inets:start(), (?NUM_DEFAULT_SERVICES + 1) = length(inets:services()), - i("start_httpd -> [application] unset services enc"), application:unset_env(inets, services), - i("start_httpd -> stop inets"), ok = inets:stop(), - - i("start_httpd -> start inets"), ok = inets:start(), - i("start_httpd -> try (and fail) start httpd service - server_name"), {error, {missing_property, server_name}} = inets:start(httpd, [{port, 0}, {server_root, PrivDir}, {document_root, PrivDir}, {bind_address, "localhost"}]), - i("start_httpd -> try (and fail) start httpd service - missing document_root"), {error, {missing_property, document_root}} = inets:start(httpd, [{port, 0}, {server_name, "httpd_test"}, {server_root, PrivDir}, {bind_address, "localhost"}]), - i("start_httpd -> try (and fail) start httpd service - missing server_root"), {error, {missing_property, server_root}} = inets:start(httpd, [{port, 0}, {server_name, "httpd_test"}, {document_root, PrivDir}, {bind_address, "localhost"}]), - i("start_httpd -> try (and fail) start httpd service - missing port"), {error, {missing_property, port}} = inets:start(httpd, HttpdConf), - i("start_httpd -> stop inets"), - ok = inets:stop(), - i("start_httpd -> done"), - ok. - + ok = inets:stop(). %%------------------------------------------------------------------------- start_ftpc(doc) -> - ["Start/stop of ftpc service"]; -start_ftpc(suite) -> - []; + [{doc, "Start/stop of ftpc service"}]; start_ftpc(Config) when is_list(Config) -> process_flag(trap_exit, true), ok = inets:start(), @@ -389,7 +306,7 @@ start_ftpc(Config) when is_list(Config) -> {'EXIT', Pid1, shutdown} -> ok after 100 -> - tsf(stand_alone_not_shutdown) + ct:fail(stand_alone_not_shutdown) end, ok = inets:stop(), ok; @@ -401,15 +318,11 @@ start_ftpc(Config) when is_list(Config) -> throw:{error, not_found} -> {skip, "No available FTP servers"} end. - - %%------------------------------------------------------------------------- -start_tftpd(doc) -> - ["Start/stop of tfpd service"]; -start_tftpd(suite) -> - []; +start_tftpd() -> + [{doc, "Start/stop of tfpd service"}]. start_tftpd(Config) when is_list(Config) -> process_flag(trap_exit, true), ok = inets:start(), @@ -441,16 +354,12 @@ start_tftpd(Config) when is_list(Config) -> application:unset_env(inets, services), ok = inets:stop(). - %%------------------------------------------------------------------------- -httpd_reload(doc) -> - ["Reload httpd configuration without restarting service"]; -httpd_reload(suite) -> - []; +httpd_reload() -> + [{doc, "Reload httpd configuration without restarting service"}]. httpd_reload(Config) when is_list(Config) -> process_flag(trap_exit, true), - i("httpd_reload -> starting"), PrivDir = ?config(priv_dir, Config), DataDir = ?config(data_dir, Config), HttpdConf = [{server_name, "httpd_test"}, @@ -458,23 +367,18 @@ httpd_reload(Config) when is_list(Config) -> {document_root, PrivDir}, {bind_address, "localhost"}], - i("httpd_reload -> start inets"), - ok = inets:start(), test_server:sleep(5000), - i("httpd_reload -> inets started - start httpd service"), - {ok, Pid0} = inets:start(httpd, [{port, 0}, {ipfamily, inet} | HttpdConf]), + {ok, Pid0} = inets:start(httpd, [{port, 0}, + {ipfamily, inet} | HttpdConf]), test_server:sleep(5000), - i("httpd_reload -> httpd service started (~p) - get port", [Pid0]), [{port, Port0}] = httpd:info(Pid0, [port]), test_server:sleep(5000), - i("httpd_reload -> Port: ~p - get document root", [Port0]), [{document_root, PrivDir}] = httpd:info(Pid0, [document_root]), test_server:sleep(5000), - i("httpd_reload -> document root: ~p - reload config", [PrivDir]), ok = httpd:reload_config([{port, Port0}, {ipfamily, inet}, {server_name, "httpd_test"}, @@ -482,11 +386,8 @@ httpd_reload(Config) when is_list(Config) -> {document_root, DataDir}, {bind_address, "localhost"}], non_disturbing), test_server:sleep(5000), - io:format("~w:~w:httpd_reload - reloaded - get document root~n", [?MODULE, ?LINE]), - [{document_root, DataDir}] = httpd:info(Pid0, [document_root]), test_server:sleep(5000), - i("httpd_reload -> document root: ~p - reload config", [DataDir]), ok = httpd:reload_config([{port, Port0}, {ipfamily, inet}, {server_name, "httpd_test"}, @@ -539,23 +440,5 @@ httpd_reload(Config) when is_list(Config) -> ok = inets:stop(httpd, Pid1), application:unset_env(inets, services), - ok = inets:stop(), - i("httpd_reload -> starting"), - ok. - - -tsf(Reason) -> - test_server:fail(Reason). - -tsp(F) -> - tsp(F, []). -tsp(F, A) -> - Timestamp = inets_lib:formated_timestamp(), - test_server:format("** ~s ** ~p ~p:" ++ F ++ "~n", [Timestamp, self(), ?MODULE | A]). - -i(F) -> - i(F, []). + ok = inets:stop(). -i(F, A) -> - Timestamp = inets_lib:formated_timestamp(), - io:format("*** ~s ~w:" ++ F ++ "~n", [Timestamp, ?MODULE | A]). diff --git a/lib/inets/test/inets_socketwrap_SUITE.erl b/lib/inets/test/inets_socketwrap_SUITE.erl new file mode 100644 index 0000000000..cfbda3ccf5 --- /dev/null +++ b/lib/inets/test/inets_socketwrap_SUITE.erl @@ -0,0 +1,154 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 1997-2015. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%% +-module(inets_socketwrap_SUITE). + +-include_lib("common_test/include/ct.hrl"). +-include("inets_test_lib.hrl"). + +%% Note: This directive should only be used in test suites. +-compile(export_all). + +suite() -> + [{ct_hooks,[ts_install_cth]}]. + +all() -> + [start_httpd_fd, start_tftpd_fd]. + +init_per_suite(Config) -> + case os:type() of + {unix, linux} -> + Config; + _ -> + {skip, linux_feature} + end. + +end_per_suite(_Config) -> + ok. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +init_per_testcase(Case, Config) -> + end_per_testcase(Case, Config), + Config. + +end_per_testcase(_, Config) -> + inets:stop(), + Config. + +%%------------------------------------------------------------------------- +start_httpd_fd() -> + [{doc, "Start/stop of httpd service with socket wrapper"}]. +start_httpd_fd(Config) when is_list(Config) -> + PrivDir = ?config(priv_dir, Config), + DataDir = ?config(data_dir, Config), + HttpdConf = [{port, 80}, {ipfamily, inet}, + {server_name, "httpd_fd_test"}, {server_root, PrivDir}, + {document_root, PrivDir}, {bind_address, any}], + case setup_node_info(node()) of + {skip, _} = Skip -> + Skip; + {Node, NodeArg} -> + InetPort = inets_test_lib:inet_port(node()), + ct:pal("Node: ~p Port ~p~n", [Node, InetPort]), + Wrapper = filename:join(DataDir, "setuid_socket_wrap"), + Cmd = Wrapper ++ + " -s -httpd_80,0:" ++ integer_to_list(InetPort) + ++ " -p " ++ os:find_executable("erl") ++ + " -- " ++ NodeArg, + ct:pal("cmd: ~p~n", [Cmd]), + case open_port({spawn, Cmd}, [stderr_to_stdout]) of + Port when is_port(Port) -> + wait_node_up(Node, 10), + ct:pal("~p", [rpc:call(Node, init, get_argument, [httpd_80])]), + ok = rpc:call(Node, inets, start, []), + {ok, Pid} = rpc:call(Node, inets, start, [httpd, HttpdConf]), + [{port, InetPort}] = rpc:call(Node, httpd, info, [Pid, [port]]), + rpc:call(Node, erlang, halt, []); + _ -> + ct:fail(open_port_failed) + end + end. +%%------------------------------------------------------------------------- +start_tftpd_fd() -> + [{doc, "Start/stop of tfpd service with socket wrapper"}]. +start_tftpd_fd(Config) when is_list(Config) -> + DataDir = ?config(data_dir, Config), + case setup_node_info(node()) of + {skip, _} = Skip -> + Skip; + {Node, NodeArg} -> + InetPort = inets_test_lib:inet_port(node()), + ct:pal("Node: ~p~n", [Node]), + Wrapper = filename:join(DataDir, "setuid_socket_wrap"), + Cmd = Wrapper ++ + " -s -tftpd_69,0:" ++ integer_to_list(InetPort) + ++ " -p " ++ os:find_executable("erl") ++ + " -- " ++ NodeArg, + ct:pal("cmd: ~p~n", [Cmd]), + case open_port({spawn, Cmd}, [stderr_to_stdout]) of + Port when is_port(Port) -> + wait_node_up(Node, 10), + ct:pal("~p", [rpc:call(Node, init, get_argument, [tftpd_69])]), + ok = rpc:call(Node, inets, start, []), + {ok, Pid} = rpc:call(Node, inets, start, + [tftpd,[{host, "localhost"}]]), + {ok, Info} = rpc:call(Node, tftp, info, [Pid]), + {value,{port, InetPort}} = lists:keysearch(port, 1, Info), + rpc:call(Node, erlang, halt, []); + _ -> + ct:fail(open_port_failed) + end + end. +%%------------------------------------------------------------------------- +%% Internal functions +%%------------------------------------------------------------------------- +setup_node_info(nonode@nohost) -> + {skip, needs_distributed_node}; +setup_node_info(Node) -> + Static = "-detached -noinput", + Name = "inets_fd_test", + NameSw = case net_kernel:longnames() of + false -> "-sname "; + _ -> "-name " + end, + StrNode = + Static ++ " " + ++ NameSw ++ " " ++ Name ++ " " + ++ "-setcookie " ++ atom_to_list(erlang:get_cookie()), + [_, Location] = string:tokens(atom_to_list(Node), "$@"), + TestNode = Name ++ "@" ++ Location, + {list_to_atom(TestNode), StrNode}. + +wait_node_up(Node, 0) -> + ct:fail({failed_to_start_node, Node}); +wait_node_up(Node, N) -> + ct:pal("(Node ~p: net_adm:ping(~p)~n", [node(), Node]), + case net_adm:ping(Node) of + pong -> + ok; + pang -> + ct:sleep(5000), + wait_node_up(Node, N-1) + end. diff --git a/lib/inets/test/inets_socketwrap_SUITE_data/Makefile.src b/lib/inets/test/inets_socketwrap_SUITE_data/Makefile.src new file mode 100644 index 0000000000..0933815b58 --- /dev/null +++ b/lib/inets/test/inets_socketwrap_SUITE_data/Makefile.src @@ -0,0 +1,39 @@ +# +# %CopyrightBegin% +# +# Copyright Ericsson AB 2015-2015. All Rights Reserved. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. +# +# %CopyrightEnd% +# + +CC = @CC@ +LD = @LD@ +CFLAGS = @CFLAGS@ +CROSSLDFLAGS = @CROSSLDFLAGS@ + +PROGS = setuid_socket_wrap@exe@ + +.PHONY: all +@IFEQ@ (@os@, linux-gnu) +all: $(PROGS) +@ELSE@ +all: +@ENDIF@ + +setuid_socket_wrap@exe@: setuid_socket_wrap@obj@ + $(LD) $(CROSSLDFLAGS) -o setuid_socket_wrap setuid_socket_wrap@obj@ @LIBS@ + +setuid_socket_wrap@obj@: setuid_socket_wrap.c + $(CC) -c $(CFLAGS) -o setuid_socket_wrap@obj@ setuid_socket_wrap.c diff --git a/lib/inets/test/inets_socketwrap_SUITE_data/setuid_socket_wrap.c b/lib/inets/test/inets_socketwrap_SUITE_data/setuid_socket_wrap.c new file mode 100644 index 0000000000..b28f6b1c08 --- /dev/null +++ b/lib/inets/test/inets_socketwrap_SUITE_data/setuid_socket_wrap.c @@ -0,0 +1,259 @@ +/* + * %CopyrightBegin% + * + * Copyright Ericsson AB 1999-2009. All Rights Reserved. + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * http://www.apache.org/licenses/LICENSE-2.0 + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + * %CopyrightEnd% + */ +/* + * setuid_socket_wrap.c + * + * ./a.out [-s [tag,][addr]:[port]]* [-d [tag,][addr]:[port]]* + * [-r [tag,]proto]* [-p erl_path]* -- program args + * + * Where: -s = stream socket, -d datagram socket and -r means raw socket. + * + */ +#ifdef HAVE_CONFIG_H +# include "config.h" +#endif + +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> +#include <string.h> +#include <ctype.h> +#include <sys/types.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <arpa/inet.h> +#include <netdb.h> + +#ifndef INADDR_NONE +#define INADDR_NONE 0xffffffff +#endif + +struct sock_list { + struct sock_list *next; + int fd; + int type; + int protocol; + struct sockaddr_in addr; + char *arg; +}; + +int parse_addr(addr, str) + struct sockaddr_in *addr; + char *str; +{ + int port = 0; + char *cp; + struct hostent *hp; + struct servent *se; + + if ((cp = strrchr(str, (int)':')) != NULL) + *cp++ = '\0'; + if (cp) { + if (!isdigit((int)cp[0])) { + if ((se = getservbyname(cp, "tcp")) != NULL) { + port = ntohs(se->s_port); + } else { + fprintf(stderr, "unknown port %s\n", cp); + return -1; + } + } else { + port = atoi(cp); + } + } + if (port < 0 || port > 0xffff) { + fprintf(stderr, "bad port number %d\n", port); + return -1; + } + + bzero(addr, sizeof(*addr)); + addr->sin_family = AF_INET; + addr->sin_port = htons(port); + if (*str == '\000') { + addr->sin_addr.s_addr = INADDR_ANY; + } else { + if ((addr->sin_addr.s_addr = inet_addr(str)) == INADDR_NONE) { + if ((hp = gethostbyname(str)) == NULL) { + fprintf(stderr, "\"%s\" unknown host or address!\n", str); + return -1; + } else { + bcopy(hp->h_addr_list[0], &addr->sin_addr.s_addr,hp->h_length); + } + } + } + return 0; +} + +struct sock_list *new_entry(type, argstr) + int type; + char *argstr; +{ + struct sock_list *sle; + char *cp; + + sle = (struct sock_list *)malloc(sizeof(struct sock_list)); + if (!sle) + return NULL; + sle->next = NULL; + sle->fd = -1; + + if ((cp = strchr(argstr, (int)',')) != NULL) { + *cp++ = '\0'; + sle->arg = argstr; + argstr = cp; + } else { + sle->arg = "-fd"; + } + sle->type = type; + switch (type) { + case SOCK_RAW: { + struct protoent *pe; + pe = getprotobyname(argstr); + if (!pe) { + fprintf(stderr, "Unknown protocol: %s\n", argstr); + free(sle); + return NULL; + } + sle->protocol = pe->p_proto; + break; + } + case SOCK_STREAM: + case SOCK_DGRAM: + sle->protocol = 0; + if (parse_addr(&sle->addr, argstr) < 0) { + free(sle); + return NULL; + } + break; + } + return sle; +} + +int open_socket(sle) + struct sock_list *sle; +{ + sle->fd = socket(AF_INET, sle->type, sle->protocol); + if (sle->fd < 0) { + perror("socket"); + return -1; + } + if (sle->type != SOCK_RAW) { +#if 0 + printf("binding fd %d to %s:%d\n", sle->fd, + inet_ntoa(sle->addr.sin_addr), ntohs(sle->addr.sin_port)); +#endif + if (bind(sle->fd, (struct sockaddr *)&sle->addr, sizeof(sle->addr))<0){ + perror("bind"); + close(sle->fd); + return -1; + } + } + return sle->fd; +} + +int main(argc, argv) + int argc; + char *argv[]; +{ + struct sock_list *sl = NULL, *sltmp = NULL; + int count = 0; + int c; + char *run_prog = NULL; + + while ((c = getopt(argc, argv, "s:d:r:p:")) != EOF) + switch (c) { + case 's': + sltmp = new_entry(SOCK_STREAM, optarg); + if (!sltmp) { + exit(1); + } + sltmp->next = sl; + sl = sltmp; + count++; + break; + case 'd': + sltmp = new_entry(SOCK_DGRAM, optarg); + if (!sltmp) { + exit(1); + } + sltmp->next = sl; + sl = sltmp; + count++; + break; + case 'r': + sltmp = new_entry(SOCK_RAW, optarg); + if (!sltmp) { + exit(1); + } + sltmp->next = sl; + sl = sltmp; + count++; + break; + case 'p': + run_prog = optarg; + break; + default: + exit(1); + } + argc -= optind; + argv += optind; + + for(sltmp = sl; sltmp != NULL; sltmp = sltmp->next) + if (open_socket(sltmp) < 0) { + fprintf(stderr, "failed to create socket!\n"); + exit(1); + } + + setuid(getuid()); + + { + int i; + char **newargv; + char *run_prog_name; + + newargv = (char **)malloc((1 + 2*count + argc + 1) * sizeof(char*)); + + if ((run_prog_name = strrchr(run_prog, (int)'/')) == NULL) + run_prog_name = run_prog; + else + run_prog_name++; + + i = 0; + newargv[i++] = run_prog_name; + + for (; argc; argc--, argv++, i++) + newargv[i] = *argv; + for(sltmp = sl; sltmp != NULL; ) { + char *fd_str = (char *)malloc(8); + if (!fd_str) exit(1); + sprintf(fd_str, "%d", sltmp->fd); + if (sltmp->arg && *(sltmp->arg)) + newargv[i++] = sltmp->arg; + newargv[i++] = fd_str; + sl = sltmp; + sltmp = sltmp->next; + free(sl); + } + newargv[i] = (char *)NULL; + execv(run_prog, newargv); + perror("exec"); + exit(1); + } + exit(0); +} diff --git a/lib/inets/test/inets_test_lib.erl b/lib/inets/test/inets_test_lib.erl index b471dcf784..f1185f7574 100644 --- a/lib/inets/test/inets_test_lib.erl +++ b/lib/inets/test/inets_test_lib.erl @@ -563,3 +563,12 @@ stop_apps(Apps) -> application:stop(App) end, Apps). +inet_port(Node) -> + {Port, Socket} = do_inet_port(Node), + rpc:call(Node, gen_tcp, close, [Socket]), + Port. + +do_inet_port(Node) -> + {ok, Socket} = rpc:call(Node, gen_tcp, listen, [0, [{reuseaddr, true}]]), + {ok, Port} = rpc:call(Node, inet, port, [Socket]), + {Port, Socket}. diff --git a/lib/kernel/doc/src/kernel_app.xml b/lib/kernel/doc/src/kernel_app.xml index 2cea38bae9..956c57f7c1 100644 --- a/lib/kernel/doc/src/kernel_app.xml +++ b/lib/kernel/doc/src/kernel_app.xml @@ -43,6 +43,7 @@ <item><c>erl_boot_server</c></item> <item><c>erl_ddll</c></item> <item><c>error_logger</c></item> + <item><c>error_logger_format_depth</c></item> <item><c>file</c></item> <item><c>global</c></item> <item><c>global_group</c></item> @@ -152,6 +153,42 @@ </item> </taglist> </item> + <tag><c>error_logger_format_depth = Depth</c></tag> + <item> + <marker id="error_logger_format_depth"></marker> + <p>This parameter can be used to limit the size of the + formatted output from the error logger event handlers.</p> + + <note><p>This configuration parameter was introduced in OTP 18.1. + It is currently experimental. Based on user feedback it + may be changed or improved in future releases, for example + to gain better control over how to limit the size of the + formatted output. We have no plans to entirely remove this + new feature, unless it turns out to be completely + useless. In OTP 19, the default may be changed to limit the + formatted output.</p></note> + + <p><c>Depth</c> is a positive integer that is the maximum + depth to which terms are printed by the error logger event + handlers included in OTP. Specifically, the two event handlers + defined by the <c>Kernel</c> application and the two event + handlers in the <c>SASL</c> application will use this + configuration parameter. (If you have implemented you own + error handlers, this configuration parameter will have no + effect on them.)</p> + + <p>The way <c>Depth</c> is used, is that format strings + string passed to the event handlers will be rewritten. + The "~p" and "~w" format controls will be replaced with + "~P" and "~W", respectively, and <c>Depth</c> will be + used as the depth parameter. See + <seealso marker="stdlib:io#format/2">io:format/2</seealso>.</p> + + <note><p>A reasonable starting value for <c>Depth</c> is + <c>30</c>. You should test crashing various processes in your + application and examine the logs from the crashes, and then + either increase or decrease the value.</p></note> + </item> <tag><c>global_groups = [GroupTuple]</c></tag> <item> <p>Defines global groups, see diff --git a/lib/sasl/doc/src/sasl_app.xml b/lib/sasl/doc/src/sasl_app.xml index 7cdb3e2ca7..fe38e69ce3 100644 --- a/lib/sasl/doc/src/sasl_app.xml +++ b/lib/sasl/doc/src/sasl_app.xml @@ -57,11 +57,19 @@ <taglist> <tag><c>sasl_report_tty_h</c></tag> <item> - <p>Formats and writes <em>supervisor reports</em>, <em>crash reports</em> and <em>progress reports</em> to <c>stdio</c>.</p> + <p>Formats and writes <em>supervisor reports</em>, <em>crash reports</em> and <em>progress reports</em> to <c>stdio</c>. + This error logger event handler will use + <seealso marker="kernel:kernel_app#error_logger_format_depth">error_logger_format_depth</seealso> + in the Kernel application to limit how much detail are printed to + for crash and supervisor reports.</p> </item> <tag><c>sasl_report_file_h</c></tag> <item> - <p>Formats and writes <em>supervisor reports</em>, <em>crash report</em> and <em>progress report</em> to a single file.</p> + <p>Formats and writes <em>supervisor reports</em>, <em>crash report</em> and <em>progress report</em> to a single file. + This error logger event handler will use + <seealso marker="kernel:kernel_app#error_logger_format_depth">error_logger_format_depth</seealso> + in the Kernel application to limit how much detail are printed to + for crash and supervisor reports.</p> </item> <tag><c>log_mf_h</c></tag> <item> diff --git a/lib/sasl/src/sasl_report.erl b/lib/sasl/src/sasl_report.erl index 1b1d432352..0b8c4212d2 100644 --- a/lib/sasl/src/sasl_report.erl +++ b/lib/sasl/src/sasl_report.erl @@ -62,27 +62,53 @@ write_report2(IO, Fd, Head, supervisor_report, Report) -> Context = sup_get(errorContext, Report), Reason = sup_get(reason, Report), Offender = sup_get(offender, Report), - FmtString = " Supervisor: ~p~n Context: ~p~n Reason: " - "~80.18p~n Offender: ~80.18p~n~n", - write_report_action(IO, Fd, Head ++ FmtString, - [Name,Context,Reason,Offender]); + {FmtString,Args} = supervisor_format([Name,Context,Reason,Offender]), + write_report_action(IO, Fd, Head, FmtString, Args); write_report2(IO, Fd, Head, progress, Report) -> Format = format_key_val(Report), - write_report_action(IO, Fd, Head ++ "~s", [Format]); + write_report_action(IO, Fd, Head, "~s", [Format]); write_report2(IO, Fd, Head, crash_report, Report) -> - Format = proc_lib:format(Report), - write_report_action(IO, Fd, Head ++ "~s", [Format]). + Depth = get_depth(), + Format = proc_lib:format(Report, latin1, Depth), + write_report_action(IO, Fd, Head, "~s", [Format]). + +supervisor_format(Args0) -> + case get_depth() of + unlimited -> + {" Supervisor: ~p~n" + " Context: ~p~n" + " Reason: ~80.18p~n" + " Offender: ~80.18p~n~n", + Args0}; + Depth -> + [A,B,C,D] = Args0, + Args = [A,Depth,B,Depth,C,Depth,D,Depth], + {" Supervisor: ~P~n" + " Context: ~P~n" + " Reason: ~80.18P~n" + " Offender: ~80.18P~n~n", + Args} + end. -write_report_action(io, Fd, Format, Args) -> - io:format(Fd, Format, Args); -write_report_action(io_lib, _Fd, Format, Args) -> - io_lib:format(Format, Args). +write_report_action(IO, Fd, Head, Format, Args) -> + S = [Head|io_lib:format(Format, Args)], + case IO of + io -> io:put_chars(Fd, S); + io_lib -> S + end. format_key_val([{Tag,Data}|Rep]) -> io_lib:format(" ~16w: ~p~n",[Tag,Data]) ++ format_key_val(Rep); format_key_val(_) -> []. +get_depth() -> + case application:get_env(kernel, error_logger_format_depth) of + {ok, Depth} when is_integer(Depth) -> + max(10, Depth); + undefined -> + unlimited + end. sup_get(Tag, Report) -> case lists:keysearch(Tag, 1, Report) of diff --git a/lib/sasl/test/Makefile b/lib/sasl/test/Makefile index 86fc57abfc..86976def6a 100644 --- a/lib/sasl/test/Makefile +++ b/lib/sasl/test/Makefile @@ -29,11 +29,13 @@ MODULES= \ alarm_handler_SUITE \ installer \ release_handler_SUITE \ + sasl_report_SUITE \ + sasl_report_suite_supervisor \ systools_SUITE \ systools_rc_SUITE \ overload_SUITE \ rb_SUITE \ - rh_test_lib + rh_test_lib \ ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/sasl/test/sasl_SUITE.erl b/lib/sasl/test/sasl_SUITE.erl index 1d76cdee6e..cd8316b451 100644 --- a/lib/sasl/test/sasl_SUITE.erl +++ b/lib/sasl/test/sasl_SUITE.erl @@ -28,10 +28,11 @@ -export([app_test/1, appup_test/1, log_mf_h_env/1, - log_file/1]). + log_file/1, + utc_log/1]). all() -> - [log_mf_h_env, log_file, app_test, appup_test]. + [log_mf_h_env, log_file, app_test, appup_test, utc_log]. groups() -> []. @@ -182,20 +183,104 @@ log_mf_h_env(Config) -> log_file(Config) -> PrivDir = ?config(priv_dir,Config), LogDir = filename:join(PrivDir,sasl_SUITE_log_dir), - ok = filelib:ensure_dir(LogDir), File = filename:join(LogDir, "file.log"), + ok = filelib:ensure_dir(File), application:stop(sasl), clear_env(sasl), - ok = application:set_env(sasl,sasl_error_logger,{file, File}, [{persistent, true}]), + _ = test_log_file(File, {file,File}), + _ = test_log_file(File, {file,File,[write]}), + + ok = file:write_file(File, <<"=PROGRESS preserve me\n">>), + <<"=PROGRESS preserve me\n",_/binary>> = + test_log_file(File, {file,File,[append]}), + + ok = application:set_env(sasl,sasl_error_logger, tty, + [{persistent, false}]), + ok = application:start(sasl). + +test_log_file(File, Arg) -> + ok = application:set_env(sasl, sasl_error_logger, Arg, + [{persistent, true}]), + ok = application:start(sasl), + application:stop(sasl), + {ok,Bin} = file:read_file(File), + ok = file:delete(File), + Lines0 = binary:split(Bin, <<"\n">>, [trim_all,global]), + Lines = [L || L <- Lines0, + binary:match(L, <<"=PROGRESS">>) =:= {0,9}], + io:format("~p:\n~p\n", [Arg,Lines]), + + %% There must be at least four PROGRESS lines. + if + length(Lines) >= 4 -> ok; + true -> ?t:fail() + end, + Bin. + +%% Make a basic test of utc_log. +utc_log(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, sasl_SUITE_log_dir), + Log = filename:join(LogDir, "utc.log"), + ok = filelib:ensure_dir(Log), + + application:stop(sasl), + clear_env(sasl), + + %% Test that the UTC marker gets added to PROGRESS lines + %% when the utc_log configuration variable is set to true. + ok = application:set_env(sasl, sasl_error_logger, {file,Log}, + [{persistent,true}]), + ok = application:set_env(sasl, utc_log, true, [{persistent,true}]), ok = application:start(sasl), application:stop(sasl), - ok = application:set_env(sasl,sasl_error_logger,{file, File, [append]}, [{persistent, true}]), + + verify_utc_log(Log, true), + + %% Test that no UTC markers gets added to PROGRESS lines + %% when the utc_log configuration variable is set to false. + ok = application:set_env(sasl, utc_log, false, [{persistent,true}]), + ok = application:start(sasl), + application:stop(sasl), + + verify_utc_log(Log, false), + + %% Test that no UTC markers gets added to PROGRESS lines + %% when the utc_log configuration variable is unset. + ok = application:unset_env(sasl, utc_log, [{persistent,true}]), ok = application:start(sasl), application:stop(sasl), - ok = application:set_env(sasl,sasl_error_logger, tty, [{persistent, false}]), + + verify_utc_log(Log, false), + + %% Change back to the standard TTY error logger. + ok = application:set_env(sasl,sasl_error_logger, tty, + [{persistent, false}]), ok = application:start(sasl). +verify_utc_log(Log, UTC) -> + {ok,Bin} = file:read_file(Log), + ok = file:delete(Log), + + Lines0 = binary:split(Bin, <<"\n">>, [trim_all,global]), + Lines = [L || L <- Lines0, + binary:match(L, <<"=PROGRESS">>) =:= {0,9}], + Setting = application:get_env(sasl, utc_log), + io:format("utc_log ~p:\n~p\n", [Setting,Lines]), + Filtered = [L || L <- Lines, + binary:match(L, <<" UTC ===">>) =:= nomatch], + %% Filtered now contains all lines WITHOUT any UTC markers. + case UTC of + false -> + %% No UTC marker on the PROGRESS line. + Filtered = Lines; + true -> + %% Each PROGRESS line must have an UTC marker. + [] = Filtered + end, + ok. + %%----------------------------------------------------------------- %% Internal diff --git a/lib/sasl/test/sasl_report_SUITE.erl b/lib/sasl/test/sasl_report_SUITE.erl new file mode 100644 index 0000000000..940234f152 --- /dev/null +++ b/lib/sasl/test/sasl_report_SUITE.erl @@ -0,0 +1,141 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(sasl_report_SUITE). +-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, + init_per_group/2,end_per_group/2]). +-export([gen_server_crash/1]). + +-export([crash_me/0,start_link/0,init/1,handle_cast/2,terminate/2]). + +-include_lib("test_server/include/test_server.hrl"). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [gen_server_crash]. + +groups() -> + []. + +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +gen_server_crash(Config) -> + try + do_gen_server_crash(Config) + after + error_logger:tty(true), + ok = application:unset_env(sasl, sasl_error_logger), + ok = application:unset_env(kernel, error_logger_format_depth), + error_logger:add_report_handler(cth_log_redirect) + end, + ok. + +do_gen_server_crash(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, ?MODULE), + KernelLog = filename:join(LogDir, "kernel.log"), + SaslLog = filename:join(LogDir, "sasl.log"), + ok = filelib:ensure_dir(SaslLog), + + error_logger:delete_report_handler(cth_log_redirect), + error_logger:tty(false), + application:stop(sasl), + ok = application:set_env(sasl, sasl_error_logger, {file,SaslLog}, + [{persistent,true}]), + application:set_env(kernel, error_logger_format_depth, 30), + error_logger:logfile({open,KernelLog}), + application:start(sasl), + io:format("~p\n", [gen_event:which_handlers(error_logger)]), + + crash_me(), + + error_logger:logfile(close), + + check_file(KernelLog, 70000, 150000), + check_file(SaslLog, 50000, 100000), + + ok. + +check_file(File, Min, Max) -> + {ok,Bin} = file:read_file(File), + Base = filename:basename(File), + io:format("*** Contents of ~s ***\n", [Base]), + io:put_chars([Bin,"\n"]), + Sz = byte_size(Bin), + io:format("Size: ~p (allowed range is ~p..~p)\n", + [Sz,Min,Max]), + if + Sz < Min -> + %% Truncated? Other problem? + ?t:fail({too_short,Base}); + Sz > Max -> + %% Truncation doesn't work? + ?t:fail({too_big,Base}); + true -> + ok + end. + +%%% +%%% gen_server that crashes. +%%% + +crash_me() -> + {ok,SuperPid} = supervisor:start_link(sasl_report_suite_supervisor, []), + [{Id,Pid,_,_}] = supervisor:which_children(SuperPid), + HugeData = gb_sets:from_list(lists:seq(1, 100000)), + gen_server:cast(Pid, HugeData), + Ref = monitor(process, Pid), + receive + {'DOWN',Ref,process,Pid,_} -> + supervisor:terminate_child(SuperPid, Id), + unlink(SuperPid), + exit(SuperPid, kill), + ok + end. + +start_link() -> + gen_server:start_link(?MODULE, [], []). + +init(_) -> + St = <<0:100000/unit:8>>, + {ok,St}. + +handle_cast(Big, St) -> + Seq = lists:seq(1, 10000), + self() ! Seq, + self() ! Seq, + self() ! Seq, + self() ! Seq, + self() ! Seq, + x = Big, + {noreply,St}. + +terminate(_, _) -> + ok. diff --git a/lib/sasl/test/sasl_report_suite_supervisor.erl b/lib/sasl/test/sasl_report_suite_supervisor.erl new file mode 100644 index 0000000000..bc92a40af2 --- /dev/null +++ b/lib/sasl/test/sasl_report_suite_supervisor.erl @@ -0,0 +1,77 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% + +-module(sasl_report_suite_supervisor). + +-behaviour(supervisor). + +%% API +-export([start_link/0]). + +%% Supervisor callbacks +-export([init/1]). + +-define(SERVER, ?MODULE). + +%%%=================================================================== +%%% API functions +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @doc +%% Starts the supervisor +%% +%% @spec start_link() -> {ok, Pid} | ignore | {error, Error} +%% @end +%%-------------------------------------------------------------------- +start_link() -> + supervisor:start_link({local, ?SERVER}, ?MODULE, []). + +%%%=================================================================== +%%% Supervisor callbacks +%%%=================================================================== + +%%-------------------------------------------------------------------- +%% @private +%% @doc +%% Whenever a supervisor is started using supervisor:start_link/[2,3], +%% this function is called by the new process to find out about +%% restart strategy, maximum restart intensity, and child +%% specifications. +%% +%% @spec init(Args) -> {ok, {SupFlags, [ChildSpec]}} | +%% ignore | +%% {error, Reason} +%% @end +%%-------------------------------------------------------------------- +init([]) -> + + SupFlags = #{strategy => one_for_one, + intensity => 1, + period => 5}, + + AChild = #{id => 'sasl_report_suit_supervisor', + start => {sasl_report_SUITE, start_link, []}, + restart => permanent, + shutdown => 5000, + type => worker, + modules => [sasl_report_SUITE]}, + + {ok, {SupFlags, [AChild]}}. diff --git a/lib/stdlib/doc/src/proc_lib.xml b/lib/stdlib/doc/src/proc_lib.xml index 86ade8840f..85f0c0c908 100644 --- a/lib/stdlib/doc/src/proc_lib.xml +++ b/lib/stdlib/doc/src/proc_lib.xml @@ -227,6 +227,17 @@ init(Parent) -> </desc> </func> <func> + <name name="format" arity="3"/> + <fsummary>Format a crash report.</fsummary> + <desc> + <p>This function can be used by a user defined event handler to + format a crash report. When <anno>Depth</anno> is given as an + positive integer, it will be used in the format string to + limit the output as follows: <c>io_lib:format("~P", + [Term,<anno>Depth</anno>])</c>.</p> + </desc> + </func> + <func> <name name="initial_call" arity="1"/> <fsummary>Extract the initial call of a <c>proc_lib</c>spawned process.</fsummary> <desc> diff --git a/lib/stdlib/src/error_logger_file_h.erl b/lib/stdlib/src/error_logger_file_h.erl index a7f3615972..48c471924e 100644 --- a/lib/stdlib/src/error_logger_file_h.erl +++ b/lib/stdlib/src/error_logger_file_h.erl @@ -24,24 +24,28 @@ %%% %%% A handler that can be connected to the error_logger -%%% event handler. -%%% Writes all events formatted to file. -%%% Handles events tagged error, emulator and info. +%%% event handler. Writes all events formatted to file. %%% %%% It can only be started from error_logger:swap_handler({logfile, File}) -%%% or error_logger:logfile(File) +%%% or error_logger:logfile(File). %%% -export([init/1, handle_event/2, handle_call/2, handle_info/2, terminate/2, code_change/3]). +-record(st, + {fd, + filename, + prev_handler, + depth=unlimited :: 'unlimited' | non_neg_integer()}). + %% This one is used when we takeover from the simple error_logger. init({File, {error_logger, Buf}}) -> case init(File, error_logger) of - {ok, {Fd, File, PrevHandler}} -> - write_events(Fd, Buf), - {ok, {Fd, File, PrevHandler}}; + {ok, State} -> + write_events(State, Buf), + {ok, State}; Error -> Error end; @@ -53,38 +57,40 @@ init(File, PrevHandler) -> process_flag(trap_exit, true), case file:open(File, [write]) of {ok,Fd} -> - {ok, {Fd, File, PrevHandler}}; + Depth = get_depth(), + State = #st{fd=Fd,filename=File,prev_handler=PrevHandler, + depth=Depth}, + {ok, State}; Error -> Error end. - + +get_depth() -> + case application:get_env(kernel, error_logger_format_depth) of + {ok, Depth} when is_integer(Depth) -> + max(10, Depth); + undefined -> + unlimited + end. + handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() -> {ok, State}; -handle_event(Event, {Fd, File, PrevHandler}) -> - write_event(Fd, tag_event(Event)), - {ok, {Fd, File, PrevHandler}}; -handle_event(_, State) -> +handle_event(Event, State) -> + write_event(State, Event), {ok, State}. -handle_info({'EXIT', Fd, _Reason}, {Fd, _File, PrevHandler}) -> +handle_info({'EXIT', Fd, _Reason}, #st{fd=Fd,prev_handler=PrevHandler}) -> case PrevHandler of [] -> remove_handler; _ -> {swap_handler, install_prev, [], PrevHandler, go_back} end; -handle_info({emulator, GL, Chars}, {Fd, File, PrevHandler}) - when node(GL) == node() -> - write_event(Fd, tag_event({emulator, GL, Chars})), - {ok, {Fd, File, PrevHandler}}; -handle_info({emulator, noproc, Chars}, {Fd, File, PrevHandler}) -> - write_event(Fd, tag_event({emulator, noproc, Chars})), - {ok, {Fd, File, PrevHandler}}; handle_info(_, State) -> {ok, State}. -handle_call(filename, {Fd, File, Prev}) -> - {ok, File, {Fd, File, Prev}}; +handle_call(filename, #st{filename=File}=State) -> + {ok, File, State}; handle_call(_Query, State) -> {ok, {error, bad_query}, State}. @@ -104,69 +110,73 @@ code_change(_OldVsn, State, _Extra) -> %%% Misc. functions. %%% ------------------------------------------------------ -tag_event(Event) -> - {erlang:universaltime(), Event}. +write_events(State, [Ev|Es]) -> + %% Write the events in reversed order. + write_events(State, Es), + write_event(State, Ev); +write_events(_State, []) -> + ok. -write_events(Fd, Events) -> write_events1(Fd, lists:reverse(Events)). +write_event(#st{fd=Fd}=State, Event) -> + case parse_event(Event) of + ignore -> + ok; + {Head,Pid,FormatList} -> + Time = maybe_utc(erlang:universaltime()), + Header = write_time(Time, Head), + Body = format_body(State, FormatList), + AtNode = if + node(Pid) =/= node() -> + ["** at node ",atom_to_list(node(Pid))," **\n"]; + true -> + [] + end, + io:put_chars(Fd, [Header,Body,AtNode]) + end. -write_events1(Fd, [Event|Es]) -> - write_event(Fd, Event), - write_events1(Fd, Es); -write_events1(_, []) -> - ok. +format_body(State, [{Format,Args}|T]) -> + S = try format(State, Format, Args) of + S0 -> + S0 + catch + _:_ -> + format(State, "ERROR: ~p - ~p\n", [Format,Args]) + end, + [S|format_body(State, T)]; +format_body(_State, []) -> + []. -write_event(Fd, {Time, {error, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(Fd, {Time, {emulator, _GL, Chars}}) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(Chars, []) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - io:format(Fd, T ++ "ERROR: ~p ~n", [Chars]) - end; -write_event(Fd, {Time, {info, _GL, {Pid, Info, _}}}) -> - T = write_time(maybe_utc(Time)), - io:format(Fd, T ++ add_node("~p~n",Pid),[Info]); -write_event(Fd, {Time, {error_report, _GL, {Pid, std_error, Rep}}}) -> - T = write_time(maybe_utc(Time)), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {info_report, _GL, {Pid, std_info, Rep}}}) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {info_msg, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(Fd, {Time, {warning_report, _GL, {Pid, std_warning, Rep}}}) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - S = format_report(Rep), - io:format(Fd, T ++ S ++ add_node("", Pid), []); -write_event(Fd, {Time, {warning_msg, _GL, {Pid, Format, Args}}}) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - io:format(Fd, T ++ S, []); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - io:format(Fd, T ++ F, [Format,Args]) - end; -write_event(_, _) -> - ok. +format(#st{depth=unlimited}, Format, Args) -> + io_lib:format(Format, Args); +format(#st{depth=Depth}, Format0, Args) -> + Format1 = io_lib:scan_format(Format0, Args), + Format = limit_format(Format1, Depth), + io_lib:build_text(Format). + +limit_format([#{control_char:=C0}=M0|T], Depth) when C0 =:= $p; + C0 =:= $w -> + C = C0 - ($a - $A), %To uppercase. + #{args:=Args} = M0, + M = M0#{control_char:=C,args:=Args++[Depth]}, + [M|limit_format(T, Depth)]; +limit_format([H|T], Depth) -> + [H|limit_format(T, Depth)]; +limit_format([], _) -> + []. + +parse_event({error, _GL, {Pid, Format, Args}}) -> + {"ERROR REPORT",Pid,[{Format,Args}]}; +parse_event({info_msg, _GL, {Pid, Format, Args}}) -> + {"INFO REPORT",Pid,[{Format, Args}]}; +parse_event({warning_msg, _GL, {Pid, Format, Args}}) -> + {"WARNING REPORT",Pid,[{Format,Args}]}; +parse_event({error_report, _GL, {Pid, std_error, Args}}) -> + {"ERROR REPORT",Pid,format_term(Args)}; +parse_event({info_report, _GL, {Pid, std_info, Args}}) -> + {"INFO REPORT",Pid,format_term(Args)}; +parse_event({warning_report, _GL, {Pid, std_warning, Args}}) -> + {"WARNING REPORT",Pid,format_term(Args)}; +parse_event(_) -> ignore. maybe_utc(Time) -> UTC = case application:get_env(sasl, utc_log) of @@ -183,30 +193,27 @@ maybe_utc(Time) -> maybe_utc(Time, true) -> {utc, Time}; maybe_utc(Time, _) -> {local, calendar:universal_time_to_local_time(Time)}. -format_report(Rep) when is_list(Rep) -> - case string_p(Rep) of +format_term(Term) when is_list(Term) -> + case string_p(Term) of true -> - io_lib:format("~s~n",[Rep]); - _ -> - format_rep(Rep) + [{"~s\n",[Term]}]; + false -> + format_term_list(Term) end; -format_report(Rep) -> - io_lib:format("~p~n",[Rep]). +format_term(Term) -> + [{"~p\n",[Term]}]. -format_rep([{Tag,Data}|Rep]) -> - io_lib:format(" ~p: ~p~n",[Tag,Data]) ++ format_rep(Rep); -format_rep([Other|Rep]) -> - io_lib:format(" ~p~n",[Other]) ++ format_rep(Rep); -format_rep(_) -> +format_term_list([{Tag,Data}|T]) -> + [{" ~p: ~p\n",[Tag,Data]}|format_term_list(T)]; +format_term_list([Data|T]) -> + [{" ~p\n",[Data]}|format_term_list(T)]; +format_term_list([]) -> + []; +format_term_list(_) -> + %% Continue to allow non-proper lists for now. + %% FIXME: Remove this clause in OTP 19. []. -add_node(X, Pid) when is_atom(X) -> - add_node(atom_to_list(X), Pid); -add_node(X, Pid) when node(Pid) =/= node() -> - lists:concat([X,"** at node ",node(Pid)," **~n"]); -add_node(X, _) -> - X. - string_p([]) -> false; string_p(Term) -> @@ -222,15 +229,10 @@ string_p1([$\b|T]) -> string_p1(T); string_p1([$\f|T]) -> string_p1(T); string_p1([$\e|T]) -> string_p1(T); string_p1([H|T]) when is_list(H) -> - case string_p1(H) of - true -> string_p1(T); - _ -> false - end; + string_p1(H) andalso string_p1(T); string_p1([]) -> true; string_p1(_) -> false. -write_time(Time) -> write_time(Time, "ERROR REPORT"). - write_time({utc,{{Y,Mo,D},{H,Mi,S}}}, Type) -> io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s UTC ===~n", [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]); diff --git a/lib/stdlib/src/error_logger_tty_h.erl b/lib/stdlib/src/error_logger_tty_h.erl index 65ea645bd9..d2df6681e3 100644 --- a/lib/stdlib/src/error_logger_tty_h.erl +++ b/lib/stdlib/src/error_logger_tty_h.erl @@ -23,145 +23,180 @@ %%% %%% A handler that can be connected to the error_logger -%%% event handler. -%%% Writes all events formatted to stdout. -%%% Handles events tagged error, emulator and info. +%%% event handler. Writes all events formatted to stdout. %%% %%% It can only be started from error_logger:swap_handler(tty) -%%% or error_logger:tty(true) +%%% or error_logger:tty(true). %%% -export([init/1, handle_event/2, handle_call/2, handle_info/2, terminate/2, code_change/3]). --export([write_event/2]). +-export([write_event/2,write_event/3]). + +-record(st, + {user, + prev_handler, + io_mod=io, + depth=unlimited}). %% This one is used when we takeover from the simple error_logger. init({[], {error_logger, Buf}}) -> User = set_group_leader(), - write_events(Buf,io), - {ok, {User, error_logger}}; + Depth = get_depth(), + State = #st{user=User,prev_handler=error_logger,depth=Depth}, + write_events(State, Buf), + {ok, State}; %% This one is used if someone took over from us, and now wants to %% go back. init({[], {error_logger_tty_h, PrevHandler}}) -> User = set_group_leader(), - {ok, {User, PrevHandler}}; + {ok, #st{user=User,prev_handler=PrevHandler}}; %% This one is used when we are started directly. init([]) -> User = set_group_leader(), - {ok, {User, []}}. + Depth = get_depth(), + {ok, #st{user=User,prev_handler=[],depth=Depth}}. + +get_depth() -> + case application:get_env(kernel, error_logger_format_depth) of + {ok, Depth} when is_integer(Depth) -> + max(10, Depth); + undefined -> + unlimited + end. handle_event({_Type, GL, _Msg}, State) when node(GL) =/= node() -> {ok, State}; handle_event(Event, State) -> - ok = write_event(tag_event(Event),io), + ok = do_write_event(State, tag_event(Event)), {ok, State}. -handle_info({'EXIT', User, _Reason}, {User, PrevHandler}) -> +handle_info({'EXIT', User, _Reason}, + #st{user=User,prev_handler=PrevHandler}=State) -> case PrevHandler of [] -> remove_handler; _ -> - {swap_handler, install_prev, {User, PrevHandler}, + {swap_handler, install_prev, State, PrevHandler, go_back} end; -handle_info({emulator, GL, Chars}, State) when node(GL) == node() -> - ok = write_event(tag_event({emulator, GL, Chars}),io), - {ok, State}; -handle_info({emulator, noproc, Chars}, State) -> - ok = write_event(tag_event({emulator, noproc, Chars}),io), - {ok, State}; handle_info(_, State) -> {ok, State}. handle_call(_Query, State) -> {ok, {error, bad_query}, State}. -% unfortunately, we can't unlink from User - links are not counted! -% if pid(User) -> unlink(User); true -> ok end, terminate(install_prev, _State) -> []; -terminate(_Reason, {_User, PrevHandler}) -> +terminate(_Reason, #st{prev_handler=PrevHandler}) -> {error_logger_tty_h, PrevHandler}. code_change(_OldVsn, State, _Extra) -> {ok, State}. +%% Exported (but unoffical) API. +write_event(Event, IoMod) -> + do_write_event(#st{io_mod=IoMod}, Event). + +write_event(Event, IoMod, Depth) -> + do_write_event(#st{io_mod=IoMod,depth=Depth}, Event). + + %%% ------------------------------------------------------ %%% Misc. functions. %%% ------------------------------------------------------ set_group_leader() -> case whereis(user) of - User when is_pid(User) -> link(User), group_leader(User,self()), User; - _ -> false + User when is_pid(User) -> + link(User), + group_leader(User,self()), + User; + _ -> + false end. tag_event(Event) -> {erlang:universaltime(), Event}. -%% IOMOd is always 'io' -write_events(Events,IOMod) -> write_events1(lists:reverse(Events),IOMod). - -write_events1([Event|Es],IOMod) -> - ok = write_event(Event,IOMod), - write_events1(Es,IOMod); -write_events1([],_IOMod) -> +write_events(State, [Ev|Es]) -> + %% Write the events in reverse order. + _ = write_events(State, Es), + _ = do_write_event(State, Ev), + ok; +write_events(_State, []) -> ok. -write_event({Time, {error, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) +do_write_event(State, {Time0, Event}) -> + case parse_event(Event) of + ignore -> + ok; + {Head,Pid,FormatList} -> + Time = maybe_utc(Time0), + Header = write_time(Time, Head), + Body = format_body(State, FormatList), + AtNode = if + node(Pid) =/= node() -> + ["** at node ",atom_to_list(node(Pid))," **\n"]; + true -> + [] + end, + Str = [Header,Body,AtNode], + case State#st.io_mod of + io_lib -> + Str; + io -> + io:put_chars(user, Str) + end end; -write_event({Time, {emulator, _GL, Chars}},IOMod) -> - T = write_time(maybe_utc(Time)), - case catch io_lib:format(Chars, []) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - format(IOMod, T ++ "ERROR: ~p ~n", [Chars]) - end; -write_event({Time, {info, _GL, {Pid, Info, _}}},IOMod) -> - T = write_time(maybe_utc(Time)), - format(IOMod, T ++ add_node("~p~n",Pid),[Info]); -write_event({Time, {error_report, _GL, {Pid, std_error, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time)), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {info_report, _GL, {Pid, std_info, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {info_msg, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time), "INFO REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) - end; -write_event({Time, {warning_report, _GL, {Pid, std_warning, Rep}}},IOMod) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - S = format_report(Rep), - format(IOMod, T ++ S ++ add_node("", Pid)); -write_event({Time, {warning_msg, _GL, {Pid, Format, Args}}},IOMod) -> - T = write_time(maybe_utc(Time), "WARNING REPORT"), - case catch io_lib:format(add_node(Format,Pid), Args) of - S when is_list(S) -> - format(IOMod, T ++ S); - _ -> - F = add_node("ERROR: ~p - ~p~n", Pid), - format(IOMod, T ++ F, [Format,Args]) - end; -write_event({_Time, _Error},_IOMod) -> +do_write_event(_, _) -> ok. +format_body(State, [{Format,Args}|T]) -> + S = try format(State, Format, Args) of + S0 -> + S0 + catch + _:_ -> + format(State, "ERROR: ~p - ~p\n", [Format,Args]) + end, + [S|format_body(State, T)]; +format_body(_State, []) -> + []. + +format(#st{depth=unlimited}, Format, Args) -> + io_lib:format(Format, Args); +format(#st{depth=Depth}, Format0, Args) -> + Format1 = io_lib:scan_format(Format0, Args), + Format = limit_format(Format1, Depth), + io_lib:build_text(Format). + +limit_format([#{control_char:=C0}=M0|T], Depth) when C0 =:= $p; + C0 =:= $w -> + C = C0 - ($a - $A), %To uppercase. + #{args:=Args} = M0, + M = M0#{control_char:=C,args:=Args++[Depth]}, + [M|limit_format(T, Depth)]; +limit_format([H|T], Depth) -> + [H|limit_format(T, Depth)]; +limit_format([], _) -> + []. + +parse_event({error, _GL, {Pid, Format, Args}}) -> + {"ERROR REPORT",Pid,[{Format,Args}]}; +parse_event({info_msg, _GL, {Pid, Format, Args}}) -> + {"INFO REPORT",Pid,[{Format, Args}]}; +parse_event({warning_msg, _GL, {Pid, Format, Args}}) -> + {"WARNING REPORT",Pid,[{Format,Args}]}; +parse_event({error_report, _GL, {Pid, std_error, Args}}) -> + {"ERROR REPORT",Pid,format_term(Args)}; +parse_event({info_report, _GL, {Pid, std_info, Args}}) -> + {"INFO REPORT",Pid,format_term(Args)}; +parse_event({warning_report, _GL, {Pid, std_warning, Args}}) -> + {"WARNING REPORT",Pid,format_term(Args)}; +parse_event(_) -> ignore. + maybe_utc(Time) -> UTC = case application:get_env(sasl, utc_log) of {ok, Val} -> Val; @@ -177,33 +212,26 @@ maybe_utc(Time) -> maybe_utc(Time, true) -> {utc, Time}; maybe_utc(Time, _) -> {local, calendar:universal_time_to_local_time(Time)}. -format(IOMod, String) -> format(IOMod, String, []). -format(io_lib, String, Args) -> io_lib:format(String, Args); -format(io, String, Args) -> io:format(user, String, Args). - -format_report(Rep) when is_list(Rep) -> - case string_p(Rep) of +format_term(Term) when is_list(Term) -> + case string_p(Term) of true -> - io_lib:format("~s~n",[Rep]); - _ -> - format_rep(Rep) + [{"~s\n",[Term]}]; + false -> + format_term_list(Term) end; -format_report(Rep) -> - io_lib:format("~p~n",[Rep]). - -format_rep([{Tag,Data}|Rep]) -> - io_lib:format(" ~p: ~p~n",[Tag,Data]) ++ format_rep(Rep); -format_rep([Other|Rep]) -> - io_lib:format(" ~p~n",[Other]) ++ format_rep(Rep); -format_rep(_) -> - []. +format_term(Term) -> + [{"~p\n",[Term]}]. -add_node(X, Pid) when is_atom(X) -> - add_node(atom_to_list(X), Pid); -add_node(X, Pid) when node(Pid) =/= node() -> - lists:concat([X,"** at node ",node(Pid)," **~n"]); -add_node(X, _) -> - X. +format_term_list([{Tag,Data}|T]) -> + [{" ~p: ~p\n",[Tag,Data]}|format_term_list(T)]; +format_term_list([Data|T]) -> + [{" ~p\n",[Data]}|format_term_list(T)]; +format_term_list([]) -> + []; +format_term_list(_) -> + %% Continue to allow non-proper lists for now. + %% FIXME: Remove this clause in OTP 19. + []. string_p([]) -> false; @@ -227,7 +255,6 @@ string_p1([H|T]) when is_list(H) -> string_p1([]) -> true; string_p1(_) -> false. -write_time(Time) -> write_time(Time, "ERROR REPORT"). write_time({utc,{{Y,Mo,D},{H,Mi,S}}},Type) -> io_lib:format("~n=~s==== ~p-~s-~p::~s:~s:~s UTC ===~n", [Type,D,month(Mo),Y,t(H),t(Mi),t(S)]); diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index bbf4f573f5..10c476a6f5 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -30,7 +30,8 @@ start/3, start/4, start/5, start_link/3, start_link/4, start_link/5, hibernate/3, init_ack/1, init_ack/2, - init_p/3,init_p/5,format/1,format/2,initial_call/1, + init_p/3,init_p/5,format/1,format/2,format/3, + initial_call/1, translate_initial_call/1, stop/1, stop/3]). @@ -700,53 +701,71 @@ format(CrashReport) -> CrashReport :: [term()], Encoding :: latin1 | unicode | utf8. -format([OwnReport,LinkReport], Encoding) -> - OwnFormat = format_report(OwnReport, Encoding), - LinkFormat = format_report(LinkReport, Encoding), +format(CrashReport, Encoding) -> + format(CrashReport, Encoding, unlimited). + +-spec format(CrashReport, Encoding, Depth) -> string() when + CrashReport :: [term()], + Encoding :: latin1 | unicode | utf8, + Depth :: unlimited | pos_integer(). + +format([OwnReport,LinkReport], Encoding, Depth) -> + Extra = {Encoding,Depth}, + OwnFormat = format_report(OwnReport, Extra), + LinkFormat = format_report(LinkReport, Extra), Str = io_lib:format(" crasher:~n~ts neighbours:~n~ts", [OwnFormat, LinkFormat]), lists:flatten(Str). -format_report(Rep, Enc) when is_list(Rep) -> - format_rep(Rep,Enc); -format_report(Rep, Enc) -> +format_report(Rep, Extra) when is_list(Rep) -> + format_rep(Rep, Extra); +format_report(Rep, {Enc,_}) -> io_lib:format("~"++modifier(Enc)++"p~n", [Rep]). -format_rep([{initial_call,InitialCall}|Rep], Enc) -> - [format_mfa(InitialCall)|format_rep(Rep, Enc)]; -format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Enc) -> - [format_exception(Class, Reason, StackTrace, Enc)|format_rep(Rep, Enc)]; -format_rep([{Tag,Data}|Rep], Enc) -> - [format_tag(Tag, Data)|format_rep(Rep, Enc)]; -format_rep(_, _Enc) -> +format_rep([{initial_call,InitialCall}|Rep], {_Enc,Depth}=Extra) -> + [format_mfa(InitialCall, Depth)|format_rep(Rep, Extra)]; +format_rep([{error_info,{Class,Reason,StackTrace}}|Rep], Extra) -> + [format_exception(Class, Reason, StackTrace, Extra)|format_rep(Rep, Extra)]; +format_rep([{Tag,Data}|Rep], Extra) -> + [format_tag(Tag, Data, Extra)|format_rep(Rep, Extra)]; +format_rep(_, _Extra) -> []. -format_exception(Class, Reason, StackTrace, Enc) -> - PF = pp_fun(Enc), +format_exception(Class, Reason, StackTrace, {Enc,_}=Extra) -> + PF = pp_fun(Extra), StackFun = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, %% EI = " exception: ", EI = " ", [EI, lib:format_exception(1+length(EI), Class, Reason, StackTrace, StackFun, PF, Enc), "\n"]. -format_mfa({M,F,Args}=StartF) -> +format_mfa({M,F,Args}=StartF, Depth) -> try A = length(Args), [" initial call: ",atom_to_list(M),$:,atom_to_list(F),$/, integer_to_list(A),"\n"] catch error:_ -> - format_tag(initial_call, StartF) + format_tag(initial_call, StartF, Depth) end. -pp_fun(Enc) -> - P = modifier(Enc) ++ "p", +pp_fun({Enc,Depth}) -> + {Letter,Tl} = case Depth of + unlimited -> {"p",[]}; + _ -> {"P",[Depth]} + end, + P = modifier(Enc) ++ Letter, fun(Term, I) -> - io_lib:format("~." ++ integer_to_list(I) ++ P, [Term]) + io_lib:format("~." ++ integer_to_list(I) ++ P, [Term|Tl]) end. -format_tag(Tag, Data) -> - io_lib:format(" ~p: ~80.18p~n", [Tag, Data]). +format_tag(Tag, Data, {_Enc,Depth}) -> + case Depth of + unlimited -> + io_lib:format(" ~p: ~80.18p~n", [Tag, Data]); + _ -> + io_lib:format(" ~p: ~80.18P~n", [Tag, Data, Depth]) + end. modifier(latin1) -> ""; modifier(_) -> "t". diff --git a/lib/stdlib/test/Makefile b/lib/stdlib/test/Makefile index d4ab674486..e366c2b755 100644 --- a/lib/stdlib/test/Makefile +++ b/lib/stdlib/test/Makefile @@ -30,6 +30,7 @@ MODULES= \ erl_lint_SUITE \ erl_pp_SUITE \ erl_scan_SUITE \ + error_logger_h_SUITE \ escript_SUITE \ ets_SUITE \ ets_tough_SUITE \ diff --git a/lib/stdlib/test/error_logger_h_SUITE.erl b/lib/stdlib/test/error_logger_h_SUITE.erl new file mode 100644 index 0000000000..b0b9c717a1 --- /dev/null +++ b/lib/stdlib/test/error_logger_h_SUITE.erl @@ -0,0 +1,400 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(error_logger_h_SUITE). +-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, + init_per_group/2,end_per_group/2]). +-export([logfile/1,logfile_truncated/1,tty/1,tty_truncated/1]). + +%% Event handler exports. +-export([init/1,handle_event/2,terminate/2]). + +-include_lib("test_server/include/test_server.hrl"). + +suite() -> [{ct_hooks,[ts_install_cth]}]. + +all() -> + [logfile,logfile_truncated,tty,tty_truncated]. + +groups() -> + []. + +init_per_suite(Config) -> + Config. + +end_per_suite(_Config) -> + ok. + +init_per_group(_GroupName, Config) -> + Config. + +end_per_group(_GroupName, Config) -> + Config. + +logfile(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, ?MODULE), + Log = filename:join(LogDir, "logfile.log"), + ok = filelib:ensure_dir(Log), + + Ev = event_templates(), + + do_one_logfile(Log, Ev, unlimited), + + Pa = "-pa " ++ filename:dirname(code:which(?MODULE)), + {ok,Node} = start_node(logfile, Pa), + error_logger:logfile({open,Log}), + ok = rpc:call(Node, erlang, apply, [fun gen_events/1,[Ev]]), + AtNode = iolist_to_binary(["** at node ",atom_to_list(Node)," **"]), + error_logger:logfile(close), + analyse_events(Log, Ev, [AtNode], unlimited), + + test_server:stop_node(Node), + + cleanup(Log), + ok. + +logfile_truncated(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, ?MODULE), + Log = filename:join(LogDir, "logfile_truncated.log"), + ok = filelib:ensure_dir(Log), + + Ev = event_templates(), + + Depth = 20, + application:set_env(kernel, error_logger_format_depth, Depth), + try + do_one_logfile(Log, Ev, Depth) + after + application:unset_env(kernel, error_logger_format_depth) + end, + + cleanup(Log), + ok. + +do_one_logfile(Log, Ev, Depth) -> + error_logger:logfile({open,Log}), + gen_events(Ev), + error_logger:logfile(close), + analyse_events(Log, Ev, [], Depth). + +tty(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, ?MODULE), + Log = filename:join(LogDir, "tty.log"), + ok = filelib:ensure_dir(Log), + + Ev = event_templates(), + + do_one_tty(Log, Ev, unlimited), + + Pa = "-pa " ++ filename:dirname(code:which(?MODULE)), + {ok,Node} = start_node(logfile, Pa), + tty_log_open(Log), + ok = rpc:call(Node, erlang, apply, [fun gen_events/1,[Ev]]), + tty_log_close(), + AtNode = iolist_to_binary(["** at node ",atom_to_list(Node)," **"]), + analyse_events(Log, Ev, [AtNode], unlimited), + + test_server:stop_node(Node), + + cleanup(Log), + ok. + +tty_truncated(Config) -> + PrivDir = ?config(priv_dir, Config), + LogDir = filename:join(PrivDir, ?MODULE), + Log = filename:join(LogDir, "tty_truncated.log"), + ok = filelib:ensure_dir(Log), + + Ev = event_templates(), + + Depth = 20, + application:set_env(kernel, error_logger_format_depth, Depth), + try + do_one_tty(Log, Ev, Depth) + after + application:unset_env(kernel, error_logger_format_depth) + end, + + cleanup(Log), + ok. + +do_one_tty(Log, Ev, Depth) -> + tty_log_open(Log), + gen_events(Ev), + tty_log_close(), + analyse_events(Log, Ev, [], Depth). + +tty_log_open(Log) -> + {ok,Fd} = file:open(Log, [write]), + Depth = case application:get_env(kernel, error_logger_format_depth) of + {ok,D} -> D; + _ -> unlimited + end, + error_logger:add_report_handler(?MODULE, {Fd,Depth}), + Fd. + +tty_log_close() -> + error_logger:delete_report_handler(?MODULE), + ok. + +event_templates() -> + [{error_msg,["Pure error string\n",[]]}, + {error_msg,["Pure error string with error ~p\n",[]]}, + {error_msg,["Error string with ~p\n", [format]]}, + {error_msg,["Error string with bad format ~p\n", []]}, + + {error_report,[error_atom]}, + {error_report,["error string"]}, + {error_report,[[{error_tag,value},error_value]]}, + + {info_msg,["Pure info string\n",[]]}, + {info_msg,["Pure info string with error ~p\n",[]]}, + {info_msg,["Pure string with ~p\n", [format]]}, + {info_msg,["Pure string with bad format ~p\n", []]}, + + {info_report,[info_atom]}, + {info_report,["info string"]}, + {info_report,[[{info_tag,value},info_value]]}, + + {warning_msg,["Pure warning string\n",[]]}, + {warning_msg,["Pure warning string with error ~p\n",[]]}, + {warning_msg,["Warning string with ~p\n", [format]]}, + {warning_msg,["Warning string with bad format ~p\n", []]}, + + {warning_report,[warning_atom]}, + {warning_report,["warning string"]}, + {warning_report,[[{warning_tag,value},warning_value]]}, + + %% Bigger terms. + {error_msg,["fairly big: ~p\n",[lists:seq(1, 128)]]}, + {error_report,[list_to_tuple(lists:seq(1, 100))]}, + {error_report,[lists:seq(32, 126)]}, + {error_report,[[{tag,lists:seq(1, 64)}]]} + ]. + +gen_events(Ev) -> + io:format("node = ~p\n", [node()]), + io:format("group leader = ~p\n", [group_leader()]), + io:format("~p\n", [gen_event:which_handlers(error_logger)]), + call_error_logger(Ev), + + {Pid,Ref} = spawn_monitor(fun() -> error(ouch) end), + receive + {'DOWN',Ref,process,Pid,_} -> + ok + end, + + %% The following calls with a custom type will be ignored. + error_logger:error_report(ignored, value), + error_logger:warning_report(ignored, value), + error_logger:info_report(ignored, value), + receive after 100 -> ok end, + ok. + +analyse_events(Log, Ev, AtNode, Depth) -> + {ok,Bin} = file:read_file(Log), + + io:format("*** Contents of log file ***\n\n~s\n", [Bin]), + + Lines = binary:split(Bin, <<"\n">>, [global,trim_all]), + io:format("~p\n", [Lines]), + + Rest = match_output(Ev, Lines, AtNode, Depth), + io:format("~p\n", [Rest]), + + [] = match_emulator_error(Rest), + ok. + + +call_error_logger([{F,Args}|T]) -> + apply(error_logger, F, Args), + call_error_logger(T); +call_error_logger([]) -> ok. + + +match_emulator_error([Head,Second,Third,_|Lines]) -> + match_head(<<"ERROR">>, Head), + {match,[{0,_}]} = re:run(Second, + "^Error in process <\\d+[.]\\d+[.]\\d+> on " + "node [^ ]* with exit value:"), + {match,[{0,_}]} = re:run(Third, "^[{]ouch,"), + Lines. + +match_output([Item|T], Lines0, AtNode, Depth) -> + try match_item(Item, Lines0, AtNode, Depth) of + Lines -> + match_output(T, Lines, AtNode, Depth) + catch + C:E -> + Stk = erlang:get_stacktrace(), + io:format("ITEM: ~p", [Item]), + io:format("LINES: ~p", [Lines0]), + erlang:raise(C, E, Stk) + end; +match_output([], Lines, _, _) -> Lines. + +match_item(Item, Lines, AtNode, Depth) -> + case item_type(Item) of + {msg,Head,Args} -> + match_format(Head, Args, Lines, AtNode, Depth); + {report,Head,Args} -> + match_term(Head, Args, Lines, AtNode, Depth) + end. + +item_type({error_msg,Args}) -> + {msg,<<"ERROR">>,Args}; +item_type({info_msg,Args}) -> + {msg,<<"INFO">>,Args}; +item_type({warning_msg,Args}) -> + {msg,<<"WARNING">>,Args}; +item_type({error_report,Args}) -> + {report,<<"ERROR">>,Args}; +item_type({info_report,Args}) -> + {report,<<"INFO">>,Args}; +item_type({warning_report,Args}) -> + {report,<<"WARNING">>,Args}. + +match_format(Tag, [Format,Args], [Head|Lines], AtNode, Depth) -> + match_head(Tag, Head), + Bin = try dl_format(Depth, Format, Args) of + Str -> + iolist_to_binary(Str) + catch + _:_ -> + S = dl_format(Depth, "ERROR: ~p - ~p~n", [Format,Args]), + iolist_to_binary(S) + end, + Expected0 = binary:split(Bin, <<"\n">>, [global,trim]), + Expected = Expected0 ++ AtNode, + match_term_lines(Expected, Lines). + +match_term(Tag, [Arg], [Head|Lines], AtNode, Depth) -> + match_head(Tag, Head), + Expected0 = match_term_get_expected(Arg, Depth), + Expected = Expected0 ++ AtNode, + match_term_lines(Expected, Lines). + +match_term_get_expected(List, Depth) when is_list(List) -> + Bin = try iolist_to_binary(dl_format(Depth, "~s\n", [List])) of + Bin0 -> Bin0 + catch + _:_ -> + iolist_to_binary(format_rep(List, Depth)) + end, + binary:split(Bin, <<"\n">>, [global,trim]); +match_term_get_expected(Term, Depth) -> + S = dl_format(Depth, "~p\n", [Term]), + Bin = iolist_to_binary(S), + binary:split(Bin, <<"\n">>, [global,trim]). + +format_rep([{Tag,Data}|Rep], Depth) -> + [dl_format(Depth, " ~p: ~p\n", [Tag,Data])| + format_rep(Rep, Depth)]; +format_rep([Other|Rep], Depth) -> + [dl_format(Depth, " ~p\n", [Other])| + format_rep(Rep, Depth)]; +format_rep([], _Depth) -> []. + +match_term_lines([Line|T], [Line|Lines]) -> + match_term_lines(T, Lines); +match_term_lines([], Lines) -> Lines. + +match_head(Tag, Head) -> + Re = <<"^=",Tag/binary, + " REPORT==== \\d\\d?-[A-Z][a-z][a-z]-\\d{4}::" + "\\d\\d:\\d\\d:\\d\\d ===$">>, + {match,_} = re:run(Head, Re). + +start_node(Name, Args) -> + case test_server:start_node(Name, slave, [{args,Args}]) of + {ok,Node} -> + {ok,Node}; + Error -> + test_server:fail(Error) + end. + +cleanup(File) -> + %% The point of this test case is not to test file operations. + %% Therefore ignore any failures. + case file:delete(File) of + ok -> + ok; + {error,Error1} -> + io:format("file:delete(~s) failed with error ~p", + [File,Error1]) + end, + Dir = filename:dirname(File), + case file:del_dir(Dir) of + ok -> + ok; + {error,Error2} -> + io:format("file:del_dir(~s) failed with error ~p", + [Dir,Error2]) + end, + ok. + + +%% Depth-limited io_lib:format. Intentionally implemented here instead +%% of using io_lib:scan_format/2 to avoid using the same implementation +%% as in the error_logger handlers. + +dl_format(unlimited, Format, Args) -> + io_lib:format(Format, Args); +dl_format(Depth, Format0, Args0) -> + {Format,Args} = dl_format_1(Format0, Args0, Depth, [], []), + io_lib:format(Format, Args). + +dl_format_1("~p"++Fs, [A|As], Depth, Facc, Acc) -> + dl_format_1(Fs, As, Depth, [$P,$~|Facc], [Depth,A|Acc]); +dl_format_1("~w"++Fs, [A|As], Depth, Facc, Acc) -> + dl_format_1(Fs, As, Depth, [$W,$~|Facc], [Depth,A|Acc]); +dl_format_1("~s"++Fs, [A|As], Depth, Facc, Acc) -> + dl_format_1(Fs, As, Depth, [$s,$~|Facc], [A|Acc]); +dl_format_1([F|Fs], As, Depth, Facc, Aacc) -> + dl_format_1(Fs, As, Depth, [F|Facc], Aacc); +dl_format_1([], [], _, Facc, Aacc) -> + {lists:reverse(Facc),lists:reverse(Aacc)}. + +%%% +%%% Our own event handler. There is no way to intercept the output +%%% from error_logger_tty_h, but we can use the same code by +%%% calling error_logger_tty_h:write_event/2. +%%% + +init({_,_}=St) -> + {ok,St}. + +handle_event(Event, {Fd,Depth}=St) -> + case error_logger_tty_h:write_event(tag_event(Event), io_lib, Depth) of + ok -> + ok; + Str when is_list(Str) -> + io:put_chars(Fd, Str) + end, + {ok,St}. + +terminate(_Reason, {Fd,_}) -> + ok = file:close(Fd), + []. + +tag_event(Event) -> + {erlang:universaltime(),Event}. diff --git a/lib/stdlib/test/proc_lib_SUITE.erl b/lib/stdlib/test/proc_lib_SUITE.erl index 36f009eec6..3a8fa74d36 100644 --- a/lib/stdlib/test/proc_lib_SUITE.erl +++ b/lib/stdlib/test/proc_lib_SUITE.erl @@ -28,7 +28,7 @@ init_per_group/2,end_per_group/2, crash/1, sync_start_nolink/1, sync_start_link/1, spawn_opt/1, sp1/0, sp2/0, sp3/1, sp4/2, sp5/1, - hibernate/1, stop/1]). + hibernate/1, stop/1, t_format/1]). -export([ otp_6345/1, init_dont_hang/1]). -export([hib_loop/1, awaken/1]). @@ -51,7 +51,7 @@ suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> [crash, {group, sync_start}, spawn_opt, hibernate, - {group, tickets}, stop]. + {group, tickets}, stop, t_format]. groups() -> [{tickets, [], [otp_6345, init_dont_hang]}, @@ -149,7 +149,11 @@ crash(Config) when is_list(Config) -> ?line ?t:fail({unexpected_message,Any}) after 2000 -> ok - end. + end, + + error_logger:delete_report_handler(?MODULE), + ok. + sync_start_nolink(Config) when is_list(Config) -> @@ -301,6 +305,7 @@ hibernate(Config) when is_list(Config) -> ?line {value,{initial_call,{?MODULE,hib_loop,[_]}}} = lists:keysearch(initial_call, 1, Report), + error_logger:delete_report_handler(?MODULE), ok. hib_loop(LoopData) -> @@ -452,6 +457,51 @@ system_terminate(crash,_Parent,_Deb,_State) -> system_terminate(Reason,_Parent,_Deb,_State) -> exit(Reason). + +t_format(_Config) -> + error_logger:tty(false), + try + t_format() + after + error_logger:tty(true) + end, + ok. + +t_format() -> + error_logger:add_report_handler(?MODULE, self()), + Pid = proc_lib:spawn(fun t_format_looper/0), + HugeData = gb_sets:from_list(lists:seq(1, 100)), + Pid ! {die,HugeData}, + Report = receive + {crash_report, Pid, Report0} -> Report0 + end, + Usz = do_test_format(Report, unlimited), + Tsz = do_test_format(Report, 20), + + if + Tsz >= Usz -> + ?t:fail(); + true -> + ok + end, + + ok. + +do_test_format(Report, Depth) -> + io:format("*** Depth = ~p", [Depth]), + S0 = proc_lib:format(Report, latin1, Depth), + S = lists:flatten(S0), + io:put_chars(S), + length(S). + +t_format_looper() -> + receive + {die,Data} -> + exit(Data); + _ -> + t_format_looper() + end. + %%----------------------------------------------------------------- %% The error_logger handler used. %%----------------------------------------------------------------- diff --git a/lib/stdlib/test/zip_SUITE.erl b/lib/stdlib/test/zip_SUITE.erl index 9d48d092cf..c275053691 100644 --- a/lib/stdlib/test/zip_SUITE.erl +++ b/lib/stdlib/test/zip_SUITE.erl @@ -556,9 +556,10 @@ unzip_to_binary(doc) -> unzip_to_binary(Config) when is_list(Config) -> DataDir = ?config(data_dir, Config), PrivDir = ?config(priv_dir, Config), + WorkDir = filename:join(PrivDir, "unzip_to_binary"), + _ = file:make_dir(WorkDir), - delete_all_in(PrivDir), - file:set_cwd(PrivDir), + ok = file:set_cwd(WorkDir), Long = filename:join(DataDir, "abc.zip"), %% Unzip a zip file into a binary @@ -569,7 +570,7 @@ unzip_to_binary(Config) when is_list(Config) -> end, FBList), %% Make sure no files created in cwd - {ok,[]} = file:list_dir(PrivDir), + {ok,[]} = file:list_dir(WorkDir), ok. @@ -578,8 +579,10 @@ zip_to_binary(doc) -> zip_to_binary(Config) when is_list(Config) -> DataDir = ?config(data_dir, Config), PrivDir = ?config(priv_dir, Config), - delete_all_in(PrivDir), - file:set_cwd(PrivDir), + WorkDir = filename:join(PrivDir, "zip_to_binary"), + _ = file:make_dir(WorkDir), + + file:set_cwd(WorkDir), FileName = "abc.txt", ZipName = "t.zip", FilePath = filename:join(DataDir, FileName), @@ -589,7 +592,7 @@ zip_to_binary(Config) when is_list(Config) -> {ok, {ZipName, ZipB}} = zip:zip(ZipName, [FileName], [memory]), %% Make sure no files created in cwd - {ok,[FileName]} = file:list_dir(PrivDir), + {ok,[FileName]} = file:list_dir(WorkDir), %% Zip to a file {ok, ZipName} = zip:zip(ZipName, [FileName]), @@ -696,11 +699,6 @@ do_delete_files([Item|Rest], Cnt) -> end, do_delete_files(Rest, Cnt + DelCnt). -delete_all_in(Dir) -> - {ok, Files} = file:list_dir(Dir), - delete_files(lists:map(fun(F) -> filename:join(Dir,F) end, - Files)). - compress_control(doc) -> ["Test control of which files that should be compressed"]; compress_control(suite) -> []; |