%% Copyright (c) 2008-2016 Robert Virding %% %% 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. %% File : lfe_lib.erl %% Author : Robert Virding %% Purpose : Lisp Flavoured Erlang library of miscellaneous functions. -module(lfe_lib). %% General library functions. -export([is_bif/2,is_erl_bif/2,is_guard_bif/2]). -export([is_symb/1,is_symb_list/1,is_proper_list/1,is_doc_string/1]). -export([is_core_form/1,is_core_func/2]). -export([proc_forms/3,proc_forms/4]). %% Standard lisp library. -export([is_lfe_bif/2, acons/3,pairlis/2,pairlis/3, assoc/2,'assoc-if'/2,'assoc-if-not'/2, rassoc/2,'rassoc-if'/2,'rassoc-if-not'/2, subst/3,'subst-if'/3,'subst-if-not'/3,sublis/2, eval/1,eval/2, 'macro-function'/1,'macro-function'/2, macroexpand/1,macroexpand/2, 'macroexpand-1'/1,'macroexpand-1'/2, 'macroexpand-all'/1,'macroexpand-all'/2]). %% Miscellaneous useful LFE functions. -export([format_exception/6,format_stacktrace/3]). -export([split_name/1]). -import(lists, [reverse/1,reverse/2,map/2,foldl/3,dropwhile/2]). %% -compile([export_all]). %% is_bif(Name, Arity) -> bool(). %% is_erl_bif(Name, Arity) -> bool(). %% is_guard_bif(Name, Arity) -> bool(). %% Collected tests for valid BIFs in guards and expressions. is_bif(Name, Ar) -> is_core_func(Name, Ar) orelse is_lfe_bif(Name, Ar) orelse is_erl_bif(Name, Ar). is_erl_bif(Op, Ar) -> erl_internal:bif(Op, Ar) orelse erl_internal:arith_op(Op, Ar) orelse erl_internal:bool_op(Op, Ar) orelse erl_internal:comp_op(Op, Ar) orelse erl_internal:list_op(Op, Ar) orelse erl_internal:send_op(Op, Ar). is_guard_bif(Op ,Ar) -> erl_internal:guard_bif(Op, Ar) orelse erl_internal:arith_op(Op, Ar) orelse erl_internal:bool_op(Op, Ar) orelse erl_internal:comp_op(Op, Ar). %% is_symb(Sexpr) -> bool(). %% is_symb_list(Sexprs) -> bool(). %% is_proper_list(Sexprs) -> bool(). %% is_doc_string(Doc) -> bool(). is_symb(S) -> is_atom(S). is_symb_list([S|Ss]) when is_atom(S) -> is_symb_list(Ss); is_symb_list([]) -> true; is_symb_list(_) -> false. %Might not be a proper list is_proper_list([_|Ss]) -> is_proper_list(Ss); is_proper_list([]) -> true; is_proper_list(_) -> false. is_doc_string(Doc) -> is_binary(Doc) or io_lib:char_list(Doc). %% is_core_form(Form) -> bool(). %% Return true if Form (name) is one of the LFE core forms, else false. %% Core data special forms. is_core_form(quote) -> true; is_core_form(cons) -> true; is_core_form(car) -> true; is_core_form(cdr) -> true; is_core_form(list) -> true; is_core_form(tuple) -> true; is_core_form(binary) -> true; is_core_form(map) -> true; is_core_form(mref) -> true; is_core_form(mset) -> true; is_core_form(mupd) -> true; is_core_form('map-get') -> true; is_core_form('map-set') -> true; is_core_form('map-update') -> true; is_core_form(function) -> true; %% Core closure special forms. is_core_form(lambda) -> true; is_core_form('match-lambda') -> true; is_core_form('let') -> true; is_core_form('let-function') -> true; is_core_form('letrec-function') -> true; is_core_form('let-macro') -> true; %% Core control special forms. is_core_form('progn') -> true; is_core_form('if') -> true; is_core_form('case') -> true; is_core_form('receive') -> true; is_core_form('catch') -> true; is_core_form('try') -> true; is_core_form('funcall') -> true; is_core_form(call) -> true; %% Core definition special forms. is_core_form('eval-when-compile') -> true; is_core_form('define-function') -> true; is_core_form('define-macro') -> true; is_core_form('define-module') -> true; is_core_form('extend-module') -> true; %% Everything else is not a core form. is_core_form(_) -> false. %% is_core_func(Name, Arity) -> bool(). %% Return true if Name/Arity is one of the LFE core functions, else %% false. For those which can take multiple arguments we accept any %% number and push checking to run time. is_core_func(cons, 2) -> true; is_core_func(car, 1) -> true; is_core_func(cdr, 1) -> true; is_core_func(list, Ar) when Ar >= 0 -> true; is_core_func(tuple, Ar) when Ar >= 0 -> true; is_core_func(binary, Ar) when Ar >= 0 -> true; is_core_func(map, Ar) when Ar >= 0, (Ar rem 2) =:= 0 -> true; is_core_func(mref, 2) -> true; is_core_func(mset, Ar) when Ar >= 0, (Ar rem 2) =:= 1 -> true; is_core_func(mupd, Ar) when Ar >= 0, (Ar rem 2) =:= 1 -> true; is_core_func('map-get', 2) -> true; is_core_func('map-set', Ar) when Ar >= 0, (Ar rem 2) =:= 1 -> true; is_core_func('map-upd', Ar) when Ar >= 0, (Ar rem 2) =:= 1 -> true; is_core_func(funcall, Ar) when Ar >= 1 -> true; is_core_func(call, Ar) when Ar >= 2 -> true; is_core_func(_, _) -> false. %% proc_forms(FormFun, Forms, State) -> {Forms,State}. %% proc_forms(FormFun, Forms, Line, State) -> {Forms,State}. %% Process a (progn ... ) nested list of forms where top level list %% has elements {Form,LineNumber}. Return a flat list of results and %% passes through State. All the elements are processed left to %% right. The accumulator is in reverse order! proc_forms(Fun, Fs, St) -> proc_top_forms(Fun, Fs, [], St). proc_forms(Fun, Fs, L, St0) -> {Rs,St1} = proc_progn_forms(Fun, Fs, L, [], St0), {reverse(Rs),St1}. proc_top_forms(Fun, [{['progn'|Bs],L}|Fs], Rs0, St0) -> {Rs1,St1} = proc_progn_forms(Fun, Bs, L, Rs0, St0), proc_top_forms(Fun, Fs, Rs1, St1); proc_top_forms(Fun, [{F,L}|Fs], Rs, St0) -> {Frs,St1} = Fun(F, L, St0), proc_top_forms(Fun, Fs, reverse(Frs, Rs), St1); proc_top_forms(_, [], Rs, St) -> {reverse(Rs),St}. proc_progn_forms(Fun, [['progn'|Bbs]|Bs], L, Rs0, St0) -> {Rs1,St1} = proc_progn_forms(Fun, Bbs, L, Rs0, St0), proc_progn_forms(Fun, Bs, L, Rs1, St1); proc_progn_forms(Fun, [B|Bs], L, Rs, St0) -> {Frs,St1} = Fun(B, L, St0), proc_progn_forms(Fun, Bs, L, reverse(Frs, Rs), St1); proc_progn_forms(_, [], _, Rs, St) -> {Rs,St}. %% proc_top_forms(Fun, [{['progn'|Bs],L}|Fs], Rs, St) -> %% proc_progn_forms(Fun, Bs, L, [], Fs, Rs, St); %% proc_top_forms(Fun, [{F,L}|Fs], Rs, St0) -> %% {Frs,St1} = Fun(F, L, St0), %% proc_top_forms(Fun, Fs, reverse(Frs, Rs), St1); %% proc_top_forms(_, [], Rs, St) -> {reverse(Rs),St}. %% proc_progn_forms(Fun, [['progn'|Bs1]|Bs], L, Bss, Fs, Rs, St) -> %% proc_progn_forms(Fun, Bs1, L, [Bs|Bss], Fs, Rs, St); %% proc_progn_forms(Fun, [B|Bs], L, Bss, Fs, Rs, St0) -> %% {Frs,St1} = Fun(B, L, St0), %% proc_progn_forms(Fun, Bs, L, Bss, Fs, reverse(Frs, Rs), St1); %% proc_progn_forms(Fun, [], L, [Bs|Bss], Fs, Rs, St) -> %% proc_progn_forms(Fun, Bs, L, Bss, Fs, Rs, St); %% proc_progn_forms(Fun, [], _, [], Fs, Rs, St) -> %% proc_top_forms(Fun, Fs, Rs, St). %% Standard lisp library functions. %% is_lfe_bif(Name, Arity) -> bool(). %% acons(Key, Value, Alist) -> Alist. %% pairlis(Keys, Values, Alist) -> Alist. %% assoc(Key, Alist) -> [Key|Value] | []. %% assoc-if(Test, Alist) -> [Key|Value] | []. %% assoc-if-not(Test, Alist) -> [Key|Value] | []. %% rassoc(Value, Alist) -> [Key|Value] | []. %% rassoc-if(Test, Alist) -> [Key|Value] | []. %% rassoc-if-not(Test, Alist) -> [Key|Value] | []. %% subst(New, Old, Tree) -> Tree. %% subst-if(New, Test, Tree) -> Tree. %% subst-if-not(New, Test, Tree) -> Tree. %% sublis(Alist, Tree) -> Tree. %% eval(Sexpr) -> Value. %% macro-function(Name [,Environment]) -> Macro | []. %% macroexpand(Form [,Environment]) -> Expansion | Form. %% macroexpand-1(Form [,Environment]) -> Expansion | Form. %% macroexpand-all(Form [,Environment]) -> Expansion | Form. is_lfe_bif(acons, 3) -> true; is_lfe_bif(pairlis, 2) -> true; is_lfe_bif(pairlis, 3) -> true; is_lfe_bif(assoc, 2) -> true; is_lfe_bif('assoc-if', 2) -> true; is_lfe_bif('assoc-if-not', 2) -> true; is_lfe_bif(rassoc, 2) -> true; is_lfe_bif('rassoc-if', 2) -> true; is_lfe_bif('rassoc-if-not', 2) -> true; is_lfe_bif(subst, 3) -> true; is_lfe_bif('subst-if', 3) -> true; is_lfe_bif('subst-if-not', 3) -> true; is_lfe_bif(sublis, 2) -> true; is_lfe_bif(eval, 1) -> true; is_lfe_bif(eval, 2) -> true; is_lfe_bif('macro-function', 1) -> true; is_lfe_bif('macro-function', 2) -> true; is_lfe_bif(macroexpand, 1) -> true; is_lfe_bif(macroexpand, 2) -> true; is_lfe_bif('macroexpand-1', 1) -> true; is_lfe_bif('macroexpand-1', 2) -> true; is_lfe_bif('macroexpand-all', 1) -> true; is_lfe_bif('macroexpand-all', 2) -> true; is_lfe_bif(_, _) -> false. acons(K, V, Alist) -> [[K|V]|Alist]. pairlis(Ks, Vs) -> pairlis(Ks, Vs, []). pairlis([K|Ks], [V|Vs], Alist) -> [[K|V]|pairlis(Ks, Vs, Alist)]; pairlis([], [], Alist) -> Alist. assoc(K, [[K|_]=Pair|_]) -> Pair; assoc(K, [_|L]) -> assoc(K, L); assoc(_, []) -> []. 'assoc-if'(Pred, [[K|_]=Pair|L]) -> case Pred(K) of true -> Pair; false -> 'assoc-if'(Pred, L) end; 'assoc-if'(_, []) -> []. 'assoc-if-not'(Pred, [[K|_]=Pair|L]) -> case Pred(K) of false -> Pair; true -> 'assoc-if-not'(Pred, L) end; 'assoc-if-not'(_, []) -> []. rassoc(V, [[_|V]=Pair|_]) -> Pair; rassoc(V, [_|L]) -> rassoc(V, L); rassoc(_, []) -> []. 'rassoc-if'(Pred, [[_|V]=Pair|L]) -> case Pred(V) of true -> Pair; false -> 'rassoc-if'(Pred, L) end; 'rassoc-if'(_, []) -> []. 'rassoc-if-not'(Pred, [[_|V]=Pair|L]) -> case Pred(V) of false -> Pair; true -> 'rassoc-if-not'(Pred, L) end; 'rassoc-if-not'(_, []) -> []. %% subst(New, Old, Tree) -> Tree. subst(New, Old, Old) -> New; subst(New, Old, [H|T]) -> [subst(New, Old,H)|subst(New, Old, T)]; subst(_, _, Tree) -> Tree. %% subst-if(New, Test, Tree) -> Tree. 'subst-if'(New, Test, Tree) -> case Test(Tree) of true -> New; false -> case Tree of [H|T] -> ['subst-if'(New, Test, H)|'subst-if'(New, Test, T)]; _ -> Tree end end. %% subst-if-not(New, Test, Tree) -> Tree. 'subst-if-not'(New, Test, Tree) -> case Test(Tree) of false -> New; true -> case Tree of [H|T] -> ['subst-if-not'(New, Test, H)|'subst-if-not'(New, Test, T)]; _ -> Tree end end. %% sublis(AList, Tree) -> Tree. sublis(Alist, Tree) -> case assoc(Tree, Alist) of [_|New] -> New; %Found it [] -> %Not there case Tree of [H|T] -> [sublis(Alist, H)|sublis(Alist, T)]; _ -> Tree end end. eval(Sexpr) -> eval(Sexpr, lfe_env:new()). %Empty environment. eval(Sexpr, Env) -> lfe_eval:expr(Sexpr, Env). 'macro-function'(Symb) -> 'macro-function'(Symb, lfe_env:new()). 'macro-function'(Symb, Env) -> case lfe_env:get_mbinding(Symb, Env) of {yes,Macro} -> Macro; no -> [] end. macroexpand(Form) -> macroexpand(Form, lfe_env:new()). macroexpand(Form, Env) -> case lfe_macro:expand_expr(Form, Env) of {yes,Exp} -> Exp; no -> Form end. 'macroexpand-1'(Form) -> 'macroexpand-1'(Form, lfe_env:new()). 'macroexpand-1'(Form, Env) -> case lfe_macro:expand_expr_1(Form, Env) of {yes,Exp} -> Exp; no -> Form end. 'macroexpand-all'(Form) -> 'macroexpand-all'(Form, lfe_env:new()). 'macroexpand-all'(Form, Env) -> lfe_macro:expand_expr_all(Form, Env). %% Miscellaneous useful LFE functions. %% split_name(Name) -> [Mod] | [Mod,Func] | [Mod,Func,Arity]. %% Split a name into its parts. Don't handle the case where there is %% no module. split_name('=:=/2') -> ['=:=',2]; split_name(Name) -> Str = atom_to_list(Name), case string:chr(Str, $:) of 0 -> [Name]; %Only module C when C > 1 -> %Don't allow empty module name Mod = list_to_atom(string:substr(Str, 1, C-1)), Rest = string:substr(Str, C+1), case string:rchr(Rest, $/) of 0 -> [Mod,list_to_atom(Rest)]; %Module and function S -> %Module, function and arity [Mod,list_to_atom(string:substr(Rest, 1, S-1)), list_to_integer(string:substr(Rest, S+1))] end end. %% format_exception(Class, Error, Stacktrace, SkipFun, FormatFun, Indentation) %% -> DeepCharList. %% Format an exception. Class, Error and Stacktrace describe the %% exception; SkipFun is used to trim the end of stack; FormatFun is %% used to format terms; and Indentation is the current column. format_exception(Cl, Error0, St0, Sf, Ff, I) -> Cs = case Cl of %Class type as string throw -> "throw"; exit -> "exit"; error -> "error" end, {Error1,St1} = case is_stacktrace(St0) of true -> {Error0,St0}; false -> {{Error0,St0},[]} end, P = "exception " ++ Cs ++ ": ", %Class description string [P,lfe_io:prettyprint1(Error1, 10, length(P)+I-1),"\n", format_stacktrace(St1, Sf, Ff)]. %% format_stacktrace(Stacktrace, SkipFun, FormatFun) -> DeepCharList. %% Format a stacktrace. SkipFun is used to trim the end of stack; %% FormatFun is used to format terms. format_stacktrace(St0, Skip, Format) -> St1 = reverse(dropwhile(Skip, reverse(St0))), Print = fun (F) -> format_stackcall(F, Format) end, map(Print, St1). format_stackcall({M,F,A}, _) when is_integer(A) -> %Pre R15 lfe_io:format1(" in ~w:~w/~w\n", [M,F,A]); format_stackcall({M,F,A}, Format) -> [" in ",Format([':',M,F|A], 5),"\n"]; format_stackcall({M,F,A,Loc},_) when is_integer(A) -> %R15 and later. lfe_io:format1(" in ~w:~w/~w ~s\n", [M,F,A,location(Loc)]); format_stackcall({M,F,A,_}, Format) -> [" in ",Format([':',M,F|A], 5),"\n"]. location(Loc) -> File = proplists:get_value(file, Loc), Line = proplists:get_value(line, Loc), if File =/= undefined, Line =/= undefined -> lfe_io:format1("(~s, line ~w)", [File,Line]); true -> "" end. is_stacktrace([{M,F,A}|Fs]) %Pre R15 when is_atom(M), is_atom(F), is_integer(A) -> is_stacktrace(Fs); is_stacktrace([{M,F,As}|Fs]) when is_atom(M), is_atom(F), length(As) >= 0 -> is_stacktrace(Fs); is_stacktrace([{M,F,A,I}|Fs]) %R15 and later when is_atom(M), is_atom(F), is_integer(A), is_list(I) -> is_stacktrace(Fs); is_stacktrace([{M,F,As,I}|Fs]) when is_atom(M), is_atom(F), length(As) >= 0, is_list(I) -> is_stacktrace(Fs); is_stacktrace([]) -> true; is_stacktrace(_) -> false.