(* ::Package:: *)

(* :Title:   AttributesOfPureFunctions   *)

(* :Author:    Leonid B.Shifrin    *)

(* :Summary:

	The package  allows to take a given pure function and "manufacture"
	from it another one, with a different set of attributes. We can also
	convert (wrap) the "normal" (DownValue-based) function into a pure 
	function. In this case, all the attributes of the initial "normal"
	function that make sense for pure functions, will be carried over.
	
*)


(* :Context:   AttributesOfPureFunctions`     *)

(* :Package version:   1.0         *)

(* :Copyright:  Copyright 2009, Leonid B.Shifrin.

	Permission is granted to distribute verbatim copies of this 
	package together with any of your packages that use it, provided
	the following acknowledgement is printed in a standard place:
	"PackageOptionChecks.m is distributed with permission  by 
	Leonid B. Shifrin."
*)


(*  :History:    Version 1.0 January 2009      *)

(*  :Keywords: pure functions, attributes  *)

(*  :Mathematica version: 5.0   *)

(*  :Discussion:

	The general functionality of the package hinges upon the undocumented
	Function[Null, body[##], attributes] construct. So far this construct
	survived to later versions of Mathematica, but there is no guarantee 
	for this to continue happening.	
	
*)



BeginPackage["AttributesOfPureFunctions`"];


(********************************************************************)
(*                          Usage messages                          *)
(********************************************************************)


RemovePFAttributes::usage =
"RemovePFAttributes[f_Function,attributes:{___Symbol}] \
removes all of the attributes <attributes> from the list \
of attributes of the pure function <f>. A new pure function \
is returned. \
RemovePFAttributes[f_Function,attribute_Symbol] is an  \
acceptable syntax for a single attribute.
";

SetPFAttributes::usage = 
"SetPFAttributes[f_Function,new:{___Symbol}] adds the \
attributes <new> to the list of attributes of the pure function \
<f>. A new pure function is returned. \
SetPFAttributes[f_Function,new_Symbol] is an \
acceptable syntax for a single attribute.
 ";

GetPFAttributes::usage = 
"GetPFAttributes[f_Function] returns a list of attributes \
of the pure function <f>";

ClearPFAttributes::usage = 
"ClearPFAttributes[f_Function] removes all attributes of \
the pure function <f>. A new pure function is returned";

ToPureFunction::usage = 
"ToPureFunction[f_Symbol] converts a function <f> to a pure function, \
respecting attributes of <f>";


(********************************************************************)
(*                          Error messages                          *)
(********************************************************************)


ToPureFunction::badarg = 
"The argument has to be a pure function (have a head Function) ";

ToPureFunction::argnum= 
"The function was called with `1` arguments. Exactly 1 argument \
was expected";

RemovePFAttributes::unknwn = 
"Can not remove unknown (or invalid for a pure function) attribute(s) `1` ";

RemovePFAttributes::badargs= 
"The first argument has to be a pure function (have a head Function), \
while the second must be a Symbol or a list of Symbols";

RemovePFAttributes::argnum = 
"The function was called with `1` argument(s). Exactly 2 arguments \
were expected";

SetPFAttributes::unknwn = 
"Can not set unknown (or invalid for a pure function) attribute(s) `1` ";

SetPFAttributes::badargs= 
"The first argument has to be a pure function (have a head Function), \
while the second must be a Symbol or a list of Symbols";

SetPFAttributes::argnum = 
"The function was called with `1` argument(s). Exactly 2 arguments \
were expected";

GetPFAttributes::badarg= 
"The argument has to be a pure function (have a head Function) ";

GetPFAttributes::argnum= 
"The function was called with `1` arguments. Exactly 1 argument \
was expected";

ClearPFAttributes::badarg = 
"The argument has to be a pure function (have a head Function) ";

ClearPFAttributes::argnum = 
"The function was called with `1` arguments. Exactly 1 argument \
was expected";



(********************************************************************)
(*                        Warning messages                          *)
(********************************************************************)


ToPureFunction::nopass = 
"Warning:  the following attributes: `1` could not be passed \
to a pure function";


(***************************************************************)
(* -------------------   PRIVATE FUNCTIONS   ------------------*) 
(***************************************************************)


Begin["`Private`"];


allowedAttributes[]=
{Flat,HoldAll,HoldAllComplete,HoldFirst,SequenceHold,
HoldRest,Listable,NHoldAll,NHoldFirst,NHoldRest,Orderless};


validAttributeQ[att_Symbol]:=MemberQ[allowedAttributes[],att];


JoinHeld[a___Hold]:=
	Hold@@Replace[Hold[a],Hold[x___]:>Sequence[x],{1}];


setAttributesF=
	Function[{current,new},
		Union[
			Join[If[Head[#]===Symbol,{#},#]&[current],new]]];


removeAttributesF=
	Function[{current,remove},
		Apply[Sequence,
			DeleteCases[{current},
				Alternatives@@remove,Infinity]/.{{}}:>{}]];


ModifyPureFunctionAttributes[f_,attributes_,action_Function]:=
ReplaceRepeated[
	ReplaceAll[f,
		{Verbatim[Function][args_,body_,attribs_:{}]:>
			Function@@JoinHeld[Hold[args],Hold[body],
				Hold[Evaluate[action[attribs,attributes]]]],
		Verbatim[Function][body_]:>
			Function[Null,body,Evaluate[action[{},attributes]]]
		}],
	{
	Verbatim[Function][args_,body_,{}]:> 
		Function@@JoinHeld[Hold[args],Hold[body]],
	Verbatim[Function][Null,body_]:> Function[body]
}];


(***************************************************************)
(* -------------------   PUBLIC  FUNCTIONS   ------------------*) 
(***************************************************************)


ToPureFunction[f_Symbol]:=
	Function[Null,f[##],
		Evaluate[
			(If[UnsameQ[#1,#2],
				Message[ToPureFunction::nopass,
						Complement[#1,#2]]];
			#2)&[#,Select[#,validAttributeQ]]&[Attributes[f]]]];



(* Error cases *)

ToPureFunction[_]:="never happens"/;Message[ToPureFunction::badarg];

ToPureFunction[x___]/;Length[{x}]=!=1:=
	"never happens"/;Message[ToPureFunction::argnum,Length[{x}]];

(***************************************************************)



RemovePFAttributes[f_Function,attribute_Symbol?validAttributeQ]:=
	RemovePFAttributes[f,{attribute}];
RemovePFAttributes[f_Function,attributes:{___Symbol?validAttributeQ}]:=
	ModifyPureFunctionAttributes[f,attributes,removeAttributesF];



(* Error cases *)

RemovePFAttributes[_Function,att:(_Symbol|{___Symbol})]/;
Select[Flatten@{att},!validAttributeQ[#]&]=!={}:=
	"never happens"/;Message[RemovePFAttributes::unknwn,
						Select[Flatten@{att},!validAttributeQ[#]&]];

RemovePFAttributes[f_,att_]/;Head[f]=!=Function||
Not[MatchQ[att,attribs:(_Symbol|{___Symbol})/;
	Select[Flatten@{attribs},!validAttributeQ[#]&]=!={}]]:=
		"never happens"/;Message[RemovePFAttributes::badargs];

RemovePFAttributes[x___]/;Length[{x}]=!=2:=
	"never happens"/;Message[RemovePFAttributes::argnum,Length[{x}]];



(***************************************************************)


SetPFAttributes[f_Function,new_Symbol?validAttributeQ]:=
	SetPFAttributes[f,{new}];

SetPFAttributes[f_Function,new:{___Symbol?validAttributeQ}]:=
	ModifyPureFunctionAttributes[f,new,setAttributesF];



(* Error cases *)

SetPFAttributes[_Function,att:(_Symbol|{___Symbol})]/;
	Select[Flatten@{att},!validAttributeQ[#]&]=!={}:=
		"never happens"/;Message[SetPFAttributes::unknwn,
							Select[Flatten@{att},
									!validAttributeQ[#]&]];

SetPFAttributes[f_,att_]/;Head[f]=!=Function||
	Not[MatchQ[att,attribs:(_Symbol|{___Symbol})/;
		Select[Flatten@{attribs},!validAttributeQ[#]&]=!={}]]:=
			"never happens"/;Message[SetPFAttributes::badargs];

SetPFAttributes[x___]/;Length[{x}]=!=2:=
	"never happens"/;Message[SetPFAttributes::argnum,Length[{x}]];



(***************************************************************)


GetPFAttributes[f_Function]:=
	If[Head[#]===Symbol,{#},#]&@If[#==={},{},First[#]]&@
		Cases[{f},
			Verbatim[Function][args_,body_,attribs_:{}]:>attribs];



(* Error cases *)

GetPFAttributes[_]:=
	"never happens"/;Message[GetPFAttributes::badarg];

GetPFAttributes[x___]/;Length[{x}]=!=1:=
	"never happens"/;Message[GetPFAttributes::argnum,Length[{x}]];



(***************************************************************)


ClearPFAttributes[f_Function]:=
	RemovePFAttributes[f,GetPFAttributes[f]];



(* Error cases *)

ClearPFAttributes[_]:=
	"never happens"/;Message[ClearPFAttributes::badarg];

ClearPFAttributes[x___]/;Length[{x}]=!=1:=
	"never happens"/;Message[ClearPFAttributes::argnum,Length[{x}]];


(***************************************************************)


End[];


Protect[RemovePFAttributes,SetPFAttributes,GetPFAttributes,
ClearPFAttributes];


EndPackage[];