Props.m

(* ::Package:: *)

(* Autogenerated Package *)

BeginPackage["Props`"];


MakeMutable::usage="Makes a Head mutable";
MakeObject::usage="Makes a Head an Object";


SetProp::usage="SetProperty but works on anything";
PropVal::usage="SetProperty but works on anything";
RemoveProp::usage="SetProperty but works on anything";
PropList::usage="SetProperty but works on anything";


BeginPackage["`Package`"];


$PropertyStore::usage="";
containsQ::usage="";
set::usage="";
get::usage="";
keys::usage="";
remove::usage="";
list::usage="";


EndPackage[];


Begin["`Private`"];


(* ::Subsection:: *)
(*Basic Interface*)



$PropertyStore=Language`NewExpressionStore["<PropertyStore>"];


(* ::Subsubsection::Closed:: *)
(*containsQ*)



containsQ[x_]:=
  $PropertyStore@"containsQ"[x];
containsQ[x_, p_]:=
  $PropertyStore@"containsQ"[x, p];


(* ::Subsubsection::Closed:: *)
(*get*)



get[x_, p_]:=
  $PropertyStore@"get"[x, p];


(* ::Subsubsection::Closed:: *)
(*set*)



set[x_, p_, v_]:=
  $PropertyStore@"put"[x, p ,v];


(* ::Subsubsection::Closed:: *)
(*remove*)



remove[x_]:=
  $PropertyStore@"remove"[x];
remove[x_, p_]:=
  $PropertyStore@"remove"[x, p];


(* ::Subsubsection::Closed:: *)
(*keys*)



keys[]:=
  $PropertyStore@"getKeys"[];
keys[x_]:=
  $PropertyStore@"getKeys"[x];


(* ::Subsubsection::Closed:: *)
(*list*)



list[]:=
  $PropertyStore@"listTable"[];


(* ::Subsection:: *)
(*Exposed*)



$$hold~SetAttributes~HoldAllComplete


(* ::Subsubsection::Closed:: *)
(*SetProp*)



SetProp[x_, p_->v_]:=
  set[x, p, v];
SetProp[x_, p_:>v_]:=
  set[x, p, $$hold@v];


(* ::Subsubsection::Closed:: *)
(*PropVal*)



PropVal[x_, p_]:=
  Replace[$PropertyStore@"get"[x, p],
    {
      Null:>If[!containsQ[x, p], Missing["PropertyAbsent", p], Null],
      $$hold[v_]:>v
      }
    ];


(* ::Subsubsection::Closed:: *)
(*PropList*)



PropList[x_]:=
  Replace[keys[x], Null->Missing["ObjectAbsent", x]]


(* ::Subsubsection::Closed:: *)
(*RemoveProp*)



RemoveProp[x_, p_]:=
  remove[x, p]


(* ::Subsubsection::Closed:: *)
(*Operator Forms*)



SetProp[x_][h:(Rule|RuleDelayed)[p_ ,v_]]:=
  SetProp[x, h];
PropVal[x_][p_]:=
  PropVal[x, p];
RemoveProp[x_][p_]:=
  RemoveProp[x, p];


(* ::Subsection:: *)
(*Mutability*)



(* ::Subsubsection::Closed:: *)
(*MakeMutable*)



MakeMutable//Clear
MakeMutable[head_Symbol, test_:(True&)]:=
  Module[{mutationHandler, objQ},
    head/:(e_head?test)[k_]:=
      PropVal[e, k];
    head/:Set[(e_head?test)[k_], v_]:=
      (
        SetProp[e, k->v];
        v
        );
    head/:SetDelayed[(e_head?test)[k_], v_]:=
      SetProp[e, k:>v];
    head/:HoldPattern[Unset[(e_head?test)[k_]]]:=
      RemoveProp[e, k];
      
    objQ~SetAttributes~HoldAllComplete;
    objQ[s_Symbol]:=MatchQ[OwnValues[s], {_:>(_head?test)}];
    mutationHandler~SetAttributes~HoldAllComplete;
    mutationHandler[Set[(s_Symbol)[k_], v_]]:=
      With[{e=s}, Set[e[k], v]];
    mutationHandler[SetDelayed[s_Symbol[k_], v_]]:=
      With[{e=s}, SetDelayed[e[k], v]];
    mutationHandler[Unset[s_Symbol[k_]]]:=
      With[{e=s}, Unset[e[k]]];
    mutationHandler[e___]:=
      (
        Language`MutationFallthrough
        );
    Language`SetMutationHandler[head, mutationHandler];
    ]


(* ::Subsubsection::Closed:: *)
(*MakeObject*)



MakeObject//Clear
MakeObject[head_Symbol[a___]]:=
  (
    e:(head[a]?System`Private`HoldEntryQ):=
      (
        System`Private`HoldSetNoEntry[e];
        e["Valid"]=True;
        e
        );
    (e_head?System`Private`HoldNoEntryQ)["Properties"]:=
      PropList[e];
    Format[e_head?System`Private`HoldNoEntryQ]:=
      RawBoxes@
        BoxForm`ArrangeSummaryBox[
          head,
          e,
          None,
          {
            "-- Object --"
            },
          {},
          StandardForm
          ];
    MakeMutable[head, System`Private`HoldNoEntryQ];
    );
MakeObject~SetAttributes~HoldAllComplete;


End[];


EndPackage[];